diff --git a/.gitignore b/.gitignore index c0852c1bdb..42e80e9e98 100644 --- a/.gitignore +++ b/.gitignore @@ -37,6 +37,7 @@ restart_timestamp # Text files (For statistical output from ocean model) *.txt +!CMakeLists.txt # Directories with individual .gitignore files are: # src/external (Externals might have a different compilation method) @@ -47,8 +48,8 @@ restart_timestamp *.TBL *DATA* -# Ignore MPAS core build files. -.mpas_core_* +# Files for detecting whether builds of cores or shared framework can be reused +.build_opts* # Ignore all runtime config files namelist.* diff --git a/CMakeLists.txt b/CMakeLists.txt new file mode 100644 index 0000000000..6f213c9145 --- /dev/null +++ b/CMakeLists.txt @@ -0,0 +1,160 @@ +## MPAS-Model +cmake_minimum_required(VERSION 3.12) + +include(${CMAKE_CURRENT_SOURCE_DIR}/cmake/Functions/MPAS_Functions.cmake) +get_mpas_version(MPAS_VERSION) +project(MPAS LANGUAGES C Fortran VERSION ${MPAS_VERSION} DESCRIPTION "MPAS - Model for Prediction Across Scales") + +list(INSERT CMAKE_MODULE_PATH 0 ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) +set(CMAKE_DIRECTORY_LABELS ${PROJECT_NAME}) +include(GNUInstallDirs) + +# Options +set(MPAS_ALL_CORES atmosphere init_atmosphere) +set(MPAS_CORES atmosphere CACHE STRING "MPAS cores to build. Options: ${MPAS_ALL_CORES}") +if(MPAS_CORES MATCHES " ") #Convert strings separated with spaces to CMake list separated with ';' + string(REPLACE " " ";" MPAS_CORES ${MPAS_CORES}) + set(MPAS_CORES ${MPAS_CORES} CACHE STRING "MPAS cores to build. Options: ${MPAS_ALL_CORES}" FORCE) +endif() +option(DO_PHYSICS "Use built-in physics schemes." TRUE) +option(MPAS_DOUBLE_PRECISION "Use double precision 64-bit Floating point." TRUE) +option(MPAS_PROFILE "Enable GPTL profiling" OFF) +option(MPAS_OPENMP "Enable OpenMP" OFF) +option(BUILD_SHARED_LIBS "Build shared libraries" ON) + +message(STATUS "[OPTION] MPAS_CORES: ${MPAS_CORES}") +message(STATUS "[OPTION] MPAS_DOUBLE_PRECISION: ${MPAS_DOUBLE_PRECISION}") +message(STATUS "[OPTION] MPAS_PROFILE: ${MPAS_PROFILE}") +message(STATUS "[OPTION] MPAS_OPENMP: ${MPAS_OPENMP}") +message(STATUS "[OPTION] BUILD_SHARED_LIBS: ${BUILD_SHARED_LIBS}") + +# Build product output locations +set(CMAKE_RUNTIME_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/bin) +set(CMAKE_LIBRARY_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) +set(CMAKE_ARCHIVE_OUTPUT_DIRECTORY ${CMAKE_BINARY_DIR}/lib) + +# Set default build type to RelWithDebInfo +if(NOT CMAKE_BUILD_TYPE) + message(STATUS "Setting default build type to Release. Specify CMAKE_BUILD_TYPE to override.") + set(CMAKE_BUILD_TYPE "Release" CACHE STRING "CMake Build type" FORCE) + set_property(CACHE CMAKE_BUILD_TYPE PROPERTY STRINGS "Debug" "Release" "MinSizeRel" "RelWithDebInfo") +endif() + +# Detect MPAS git version +if(NOT MPAS_GIT_VERSION) + find_package(Git QUIET) + if(GIT_FOUND) + execute_process(COMMAND ${GIT_EXECUTABLE} describe --dirty + WORKING_DIRECTORY "${CMAKE_SOURCE_DIR}" + OUTPUT_VARIABLE _mpas_git_version + ERROR_QUIET OUTPUT_STRIP_TRAILING_WHITESPACE) + else() + set(_mpas_git_version "Unknown") + endif() + set(MPAS_GIT_VERSION ${_mpas_git_version} CACHE STRING "MPAS-Model git version") +endif() + +### Dependencies +find_package(OpenMP COMPONENTS Fortran) +find_package(MPI REQUIRED COMPONENTS Fortran) +find_package(NetCDF REQUIRED COMPONENTS Fortran C) +find_package(PnetCDF REQUIRED COMPONENTS Fortran) +find_package(PIO REQUIRED COMPONENTS Fortran C) +if(MPAS_PROFILE) + find_package(GPTL REQUIRED) +endif() + +# Find C pre-processor +if(CMAKE_C_COMPILER_ID MATCHES GNU) + find_program(CPP_EXECUTABLE NAMES cpp REQUIRED) + set(CPP_EXTRA_FLAGS -traditional) +elseif(CMAKE_C_COMPILER_ID MATCHES "(Apple)?Clang" ) + find_program(CPP_EXECUTABLE NAMES cpp REQUIRED) +else() + message(STATUS "Unknown compiler: ${CMAKE_C_COMPILER_ID}") + set(CPP_EXECUTABLE ${CMAKE_C_COMPILER}) +endif() + +## Common Variables + +# Fortran module output directory for build interface +set(MPAS_MODULE_DIR ${PROJECT_NAME}/module/${CMAKE_Fortran_COMPILER_ID}/${CMAKE_Fortran_COMPILER_VERSION}) +# Install Fortran module directory +install(DIRECTORY ${CMAKE_BINARY_DIR}/${MPAS_MODULE_DIR}/ DESTINATION ${CMAKE_INSTALL_LIBDIR}/${MPAS_MODULE_DIR}/) + +# Location of common subdriver module compiled by each cores +set(MPAS_MAIN_SRC ${CMAKE_CURRENT_SOURCE_DIR}/src/driver/mpas.F) +set(MPAS_SUBDRIVER_SRC ${CMAKE_CURRENT_SOURCE_DIR}/src/driver/mpas_subdriver.F) + +## Create targets +add_subdirectory(src/external/ezxml) # Target: MPAS::external::ezxml +if(ESMF_FOUND) + message(STATUS "Configure MPAS for external ESMF") + add_definitions(-DMPAS_EXTERNAL_ESMF_LIB -DMPAS_NO_ESMF_INIT) + add_library(${PROJECT_NAME}::external::esmf ALIAS esmf) +else() + message(STATUS "Configure MPAS for internal ESMF") + add_subdirectory(src/external/esmf_time_f90) # Target: MPAS::external::esmf_time +endif() +add_subdirectory(src/tools/input_gen) # Targets: namelist_gen, streams_gen +add_subdirectory(src/tools/registry) # Targets: mpas_parse_ +add_subdirectory(src/framework) # Target: MPAS::framework +add_subdirectory(src/operators) # Target: MPAS::operators + +foreach(_core IN LISTS MPAS_CORES) + add_subdirectory(src/core_${_core}) # Target: MPAS::core:: +endforeach() + +### Package config +include(CMakePackageConfigHelpers) + +# Build-tree target exports +export(EXPORT ${PROJECT_NAME}ExportsExternal NAMESPACE ${PROJECT_NAME}::external:: FILE ${PROJECT_NAME}-targets-external.cmake) +export(EXPORT ${PROJECT_NAME}Exports NAMESPACE ${PROJECT_NAME}:: FILE ${PROJECT_NAME}-targets.cmake) +export(EXPORT ${PROJECT_NAME}ExportsCore NAMESPACE ${PROJECT_NAME}::core:: FILE ${PROJECT_NAME}-targets-core.cmake) + +# CMake Config file install location +set(CONFIG_INSTALL_DESTINATION ${CMAKE_INSTALL_LIBDIR}/cmake/${PROJECT_NAME}) +# Install MPAS-supplied Find.cmake modules for use by downstream CMake dependencies +install(DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +## -config.cmake: build-tree +# Variables to export for use from build-tree +set(BINDIR ${CMAKE_BINARY_DIR}/bin) +set(CORE_DATADIR_ROOT ${CMAKE_BINARY_DIR}/${PROJECT_NAME}) +set(CMAKE_MODULE_INSTALL_PATH ${CMAKE_CURRENT_SOURCE_DIR}/cmake/Modules) +string(TOLOWER ${PROJECT_NAME} PROJECT_NAME_LOWER) +configure_package_config_file(cmake/PackageConfig.cmake.in ${PROJECT_NAME_LOWER}-config.cmake + INSTALL_DESTINATION . + INSTALL_PREFIX ${CMAKE_CURRENT_BINARY_DIR} + PATH_VARS BINDIR CORE_DATADIR_ROOT CMAKE_MODULE_INSTALL_PATH) + +## -config.cmake: install-tree +# Variables to export for use from install-tree +set(BINDIR ${CMAKE_INSTALL_BINDIR}) +set(CORE_DATADIR_ROOT ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}) +set(CMAKE_MODULE_INSTALL_PATH ${CONFIG_INSTALL_DESTINATION}/Modules) +configure_package_config_file(cmake/PackageConfig.cmake.in install/${PROJECT_NAME_LOWER}-config.cmake + INSTALL_DESTINATION ${CONFIG_INSTALL_DESTINATION} + PATH_VARS BINDIR CORE_DATADIR_ROOT CMAKE_MODULE_INSTALL_PATH) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/install/${PROJECT_NAME_LOWER}-config.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +## -config-version.cmake +write_basic_package_version_file( + ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME_LOWER}-config-version.cmake + VERSION ${PROJECT_VERSION} + COMPATIBILITY AnyNewerVersion) +install(FILES ${CMAKE_CURRENT_BINARY_DIR}/${PROJECT_NAME_LOWER}-config-version.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) + +## package-targets.cmake and package-targets-.cmake +install(EXPORT ${PROJECT_NAME}ExportsExternal NAMESPACE ${PROJECT_NAME}::external:: + FILE ${PROJECT_NAME_LOWER}-targets-external.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(EXPORT ${PROJECT_NAME}Exports NAMESPACE ${PROJECT_NAME}:: + FILE ${PROJECT_NAME_LOWER}-targets.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) +install(EXPORT ${PROJECT_NAME}ExportsCore NAMESPACE ${PROJECT_NAME}::core:: + FILE ${PROJECT_NAME_LOWER}-targets-core.cmake + DESTINATION ${CONFIG_INSTALL_DESTINATION}) diff --git a/LICENSE b/LICENSE index f6af5ee0a0..c8060c7f24 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2018, Los Alamos National Security, LLC (LANS) (Ocean: LA-CC-13-047; +Copyright (c) 2013-2019, Los Alamos National Security, LLC (LANS) (Ocean: LA-CC-13-047; Land Ice: LA-CC-13-117) and the University Corporation for Atmospheric Research (UCAR). All rights reserved. diff --git a/Makefile b/Makefile index f0df1d9122..e77a815de5 100644 --- a/Makefile +++ b/Makefile @@ -1,10 +1,43 @@ -MODEL_FORMULATION = +MODEL_FORMULATION = +ifneq "${MPAS_SHELL}" "" + SHELL = ${MPAS_SHELL} +endif dummy: ( $(MAKE) error ) -xlf: +gnu: # BUILDTARGET GNU Fortran, C, and C++ compilers + ( $(MAKE) all \ + "FC_PARALLEL = mpif90" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpicxx" \ + "FC_SERIAL = gfortran" \ + "CC_SERIAL = gcc" \ + "CXX_SERIAL = g++" \ + "FFLAGS_PROMOTION = -fdefault-real-8 -fdefault-double-8" \ + "FFLAGS_OPT = -std=f2008 -O3 -ffree-line-length-none -fconvert=big-endian -ffree-form" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "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" \ + "FFLAGS_OMP = -fopenmp" \ + "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fPIC" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +xlf: # BUILDTARGET IBM XL compilers ( $(MAKE) all \ "FC_PARALLEL = mpifort" \ "CC_PARALLEL = mpicc" \ @@ -13,23 +46,55 @@ xlf: "CC_SERIAL = xlc_r" \ "CXX_SERIAL = xlc++_r" \ "FFLAGS_PROMOTION = -qrealsize=8" \ - "FFLAGS_OPT = -O3 -qufmt=be" \ + "FFLAGS_OPT = -O3 -qufmt=be -WF,-qnotrigraph" \ "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -O0 -g -C -qufmt=be" \ + "FFLAGS_DEBUG = -O0 -g -C -qufmt=be -WF,-qnotrigraph" \ "CFLAGS_DEBUG = -O0 -g" \ "CXXFLAGS_DEBUG = -O0 -g" \ "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "PICFLAG = -qpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) - -ftn: + +xlf-summit-omp-offload: # BUILDTARGET IBM XL compilers w/OpenMP offloading on ORNL Summit + ( $(MAKE) all \ + "FC_PARALLEL = mpif90" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpiCC" \ + "FC_SERIAL = xlf90_r" \ + "CC_SERIAL = xlc_r" \ + "CXX_SERIAL = xlc++_r" \ + "FFLAGS_PROMOTION = -qrealsize=8" \ + "FFLAGS_OPT = -g -qfullpath -qmaxmem=-1 -qphsinfo -qzerosize -qfree=f90 -qxlf2003=polymorphic -qspillsize=2500 -qextname=flush -O2 -qstrict -Q" \ + "CFLAGS_OPT = -g -qfullpath -qmaxmem=-1 -qphsinfo -O3" \ + "CXXFLAGS_OPT = -g -qfullpath -qmaxmem=-1 -qphsinfo -O3" \ + "LDFLAGS_OPT = -Wl,--relax -Wl,--allow-multiple-definition -qsmp -qoffload -lcudart -L$(CUDA_DIR)/lib64" \ + "FFLAGS_GPU = -qsmp -qoffload" \ + "LDFLAGS_GPU = -qsmp -qoffload -lcudart -L$(CUDA_DIR)/lib64" \ + "FFLAGS_DEBUG = -O0 -g -qinitauto=7FF7FFFF -qflttrap=ov:zero:inv:en" \ + "CFLAGS_DEBUG = -O0 -g" \ + "CXXFLAGS_DEBUG = -O0 -g" \ + "LDFLAGS_DEBUG = -O0 -g" \ + "FFLAGS_OMP = -qsmp=omp" \ + "CFLAGS_OMP = -qsmp=omp" \ + "PICFLAG = -qpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENMP_OFFLOAD = $(OPENMP_OFFLOAD)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DFORTRAN_SAME -DCPRIBM -DLINUX" ) + +ftn: # BUILDTARGET Cray compilers ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -44,13 +109,17 @@ ftn: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -titan-cray: +titan-cray: # BUILDTARGET (deprecated) Cray compilers with options for ORNL Titan ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -62,13 +131,44 @@ titan-cray: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +nvhpc: # BUILDTARGET NVIDIA HPC SDK + ( $(MAKE) all \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = nvfortran" \ + "CC_SERIAL = nvc" \ + "CXX_SERIAL = nvc++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -gopt -O4 -byteswapio -Mfree" \ + "CFLAGS_OPT = -gopt -O3" \ + "CXXFLAGS_OPT = -gopt -O3" \ + "LDFLAGS_OPT = -gopt -O3" \ + "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ + "CFLAGS_DEBUG = -O0 -g -traceback" \ + "CXXFLAGS_DEBUG = -O0 -g -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Ktrap=divz,fp,inv,ovf -traceback" \ + "FFLAGS_OMP = -mp" \ + "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC = -Mnofma -acc -gpu=cc70,cc80 -Minfo=accel" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) -pgi: +pgi: # BUILDTARGET PGI compiler suite ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -84,16 +184,51 @@ pgi: "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ "CFLAGS_DEBUG = -O0 -g -traceback" \ "CXXFLAGS_DEBUG = -O0 -g -traceback" \ - "LDFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -Ktrap=divz,fp,inv,ovf -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Ktrap=divz,fp,inv,ovf -traceback" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "FFLAGS_ACC = -Mnofma -acc -Minfo=accel" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) -pgi-nersc: +pgi-summit: # BUILDTARGET PGI compiler suite w/OpenACC options for ORNL Summit + ( $(MAKE) all \ + "FC_PARALLEL = mpif90" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpicxx" \ + "FC_SERIAL = pgf90" \ + "CC_SERIAL = pgcc" \ + "CXX_SERIAL = pgc++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -g -O3 -byteswapio -Mfree" \ + "CFLAGS_OPT = -O3 " \ + "CXXFLAGS_OPT = -O3 " \ + "LDFLAGS_OPT = -O3 " \ + "FFLAGS_ACC = -acc -Minfo=accel -ta=tesla:cc70,cc60,deepcopy,nollvm " \ + "CFLAGS_ACC = -acc -Minfo=accel -ta=tesla:cc70,cc60,deepcopy,nollvm " \ + "FFLAGS_DEBUG = -O0 -g -Mbounds -Mchkptr -byteswapio -Mfree -Ktrap=divz,fp,inv,ovf -traceback" \ + "CFLAGS_DEBUG = -O0 -g -traceback" \ + "CXXFLAGS_DEBUG = -O0 -g -traceback" \ + "LDFLAGS_DEBUG = -O0 -g -Mbounds -Ktrap=divz,fp,inv,ovf -traceback" \ + "FFLAGS_OMP = -mp" \ + "CFLAGS_OMP = -mp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = -DpgiFortran -D_MPI -DUNDERSCORE" ) + +pgi-nersc: # BUILDTARGET (deprecated) PGI compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -108,13 +243,14 @@ pgi-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) -pgi-llnl: +pgi-llnl: # BUILDTARGET (deprecated) PGI compilers on LLNL machines ( $(MAKE) all \ "FC_PARALLEL = mpipgf90" \ "CC_PARALLEL = pgcc" \ @@ -129,13 +265,14 @@ pgi-llnl: "LDFLAGS_OPT = " \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DCPRPGI" ) -ifort: +ifort: # BUILDTARGET Intel Fortran, C, and C++ compiler suite ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -148,19 +285,21 @@ ifort: "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "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 -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -ifort-scorep: +ifort-scorep: # BUILDTARGET Intel compiler suite with ScoreP profiling library ( $(MAKE) all \ "FC_PARALLEL = scorep --compiler mpif90" \ "CC_PARALLEL = scorep --compiler mpicc" \ @@ -173,19 +312,20 @@ ifort-scorep: "CFLAGS_OPT = -O3 -g" \ "CXXFLAGS_OPT = -O3 -g" \ "LDFLAGS_OPT = -O3 -g" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "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" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -ifort-gcc: +ifort-gcc: # BUILDTARGET Intel Fortran compiler and GNU C/C++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -198,19 +338,47 @@ ifort-gcc: "CFLAGS_OPT = -O3" \ "CXXFLAGS_OPT = -O3" \ "LDFLAGS_OPT = -O3" \ - "FFLAGS_DEBUG = -g -convert big_endian -free -CU -CB -check all -fpe0 -traceback" \ + "FFLAGS_DEBUG = -g -convert big_endian -free -check all -fpe0 -traceback" \ "CFLAGS_DEBUG = -g" \ "CXXFLAGS_DEBUG = -g" \ "LDFLAGS_DEBUG = -g -fpe0 -traceback" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +intel-mpi: # BUILDTARGET Intel compiler suite with Intel MPI library + ( $(MAKE) all \ + "FC_PARALLEL = mpiifort" \ + "CC_PARALLEL = mpiicc" \ + "CXX_PARALLEL = mpiicpc" \ + "FC_SERIAL = ifort" \ + "CC_SERIAL = icc" \ + "CXX_SERIAL = icpc" \ + "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 -CU -CB -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 -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -gfortran: +gfortran: # BUILDTARGET GNU Fortran, C, and C++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -219,23 +387,28 @@ gfortran: "CC_SERIAL = gcc" \ "CXX_SERIAL = g++" \ "FFLAGS_PROMOTION = -fdefault-real-8 -fdefault-double-8" \ - "FFLAGS_OPT = -O3 -m64 -ffree-line-length-none -fconvert=big-endian -ffree-form" \ - "CFLAGS_OPT = -O3 -m64" \ - "CXXFLAGS_OPT = -O3 -m64" \ - "LDFLAGS_OPT = -O3 -m64" \ - "FFLAGS_DEBUG = -g -m64 -ffree-line-length-none -fconvert=big-endian -ffree-form -fbounds-check -fbacktrace -ffpe-trap=invalid,zero,overflow" \ - "CFLAGS_DEBUG = -g -m64" \ - "CXXFLAGS_DEBUG = -O3 -m64" \ - "LDFLAGS_DEBUG = -g -m64" \ + "FFLAGS_OPT = -O3 -ffree-line-length-none -fconvert=big-endian -ffree-form" \ + "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" \ + "CFLAGS_DEBUG = -g" \ + "CXXFLAGS_DEBUG = -g" \ + "LDFLAGS_DEBUG = -g" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "FFLAGS_ACC =" \ + "CFLAGS_ACC =" \ + "PICFLAG = -fPIC" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "OPENACC = $(OPENACC)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -gfortran-clang: +gfortran-clang: # BUILDTARGET GNU Fortran compiler with LLVM clang/clang++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc -cc=clang" \ @@ -254,13 +427,14 @@ gfortran-clang: "LDFLAGS_DEBUG = -g -m64" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -g95: +g95: # BUILDTARGET (deprecated) G95 Fortran compiler with GNU C/C++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpif90" \ "CC_PARALLEL = mpicc" \ @@ -275,13 +449,14 @@ g95: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -fopenmp" \ "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -pathscale-nersc: +pathscale-nersc: # BUILDTARGET (deprecated) Pathscale compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -296,13 +471,14 @@ pathscale-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -mp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -cray-nersc: +cray-nersc: # BUILDTARGET (deprecated) Cray compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -317,13 +493,14 @@ cray-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = " \ "CFLAGS_OMP = " \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -gnu-nersc: +gnu-nersc: # BUILDTARGET (deprecated) GNU compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -340,13 +517,14 @@ gnu-nersc: "CFLAGS_DEBUG = -g -m64" \ "CXXFLAGS_DEBUG = -g -m64" \ "LDFLAGS_DEBUG = -g -m64" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "SERIAL = $(SERIAL)" \ "USE_PAPI = $(USE_PAPI)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -DUNDERSCORE -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI $(FILE_OFFSET) $(ZOLTAN_DEFINE)" ) -intel-nersc: +intel-nersc: # BUILDTARGET (deprecated) Intel compilers on NERSC machines ( $(MAKE) all \ "FC_PARALLEL = ftn" \ "CC_PARALLEL = cc" \ @@ -361,17 +539,18 @@ intel-nersc: "LDFLAGS_OPT = -O3" \ "FFLAGS_OMP = -qopenmp" \ "CFLAGS_OMP = -qopenmp" \ - "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -free -CU -CB -check all -gen-interfaces -warn interfaces -traceback" \ + "FFLAGS_DEBUG = -real-size 64 -g -convert big_endian -free -check all -gen-interfaces -warn interfaces -traceback" \ "CFLAGS_DEBUG = -g -traceback" \ "CXXFLAGS_DEBUG = -g -traceback" \ "LDFLAGS_DEBUG = -g -traceback" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -bluegene: +bluegene: # BUILDTARGET (deprecated) IBM XL compilers on BlueGene/Q systems ( $(MAKE) all \ "FC_PARALLEL = mpixlf95_r" \ "CC_PARALLEL = mpixlc_r" \ @@ -390,13 +569,14 @@ bluegene: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -qsmp=omp" \ "CFLAGS_OMP = -qsmp=omp" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) -llvm: +llvm: # BUILDTARGET LLVM flang, clang, and clang++ compilers ( $(MAKE) all \ "FC_PARALLEL = mpifort" \ "CC_PARALLEL = mpicc" \ @@ -415,66 +595,189 @@ llvm: "LDFLAGS_DEBUG = -O0 -g" \ "FFLAGS_OMP = -mp" \ "CFLAGS_OMP = -fopenmp" \ + "PICFLAG = -fpic" \ + "BUILD_TARGET = $(@)" \ "CORE = $(CORE)" \ "DEBUG = $(DEBUG)" \ "USE_PAPI = $(USE_PAPI)" \ "OPENMP = $(OPENMP)" \ - "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE" ) - -CPPINCLUDES = -FCINCLUDES = -LIBS = -ifneq ($(wildcard $(PIO)/lib), ) # Check for newer PIO version -ifeq "$(USE_PIO2)" "true" - FCINCLUDES = -I$(PIO)/include - override CPPFLAGS += -DUSE_PIO2 - LIBS = -L$(PIO)/lib -lpiof -lpioc -ifneq ($(wildcard $(PIO)/lib/libgptl.a), ) # Check for GPTL library for PIO2 - LIBS += -lgptl -endif + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI" ) + +nag: # BUILDTARGET NAG Fortran compiler and GNU C/C++ compilers + ( $(MAKE) all \ + "FC_PARALLEL = mpifort" \ + "CC_PARALLEL = mpicc" \ + "CXX_PARALLEL = mpic++" \ + "FC_SERIAL = nagfor" \ + "CC_SERIAL = gcc" \ + "CXX_SERIAL = g++" \ + "FFLAGS_PROMOTION = -r8" \ + "FFLAGS_OPT = -free -mismatch -O3 -convert=big_ieee" \ + "CFLAGS_OPT = -O3" \ + "CXXFLAGS_OPT = -O3" \ + "LDFLAGS_OPT = -O3" \ + "FFLAGS_DEBUG = -free -mismatch -O0 -g -C -convert=big_ieee" \ + "CFLAGS_DEBUG = -O0 -g -Wall -pedantic" \ + "CXXFLAGS_DEBUG = -O0 -g -Wall -pedantic" \ + "LDFLAGS_DEBUG = -O0 -g -C" \ + "FFLAGS_OMP = -qsmp=omp" \ + "CFLAGS_OMP = -qsmp=omp" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "OPENMP = $(OPENMP)" \ + "CPPFLAGS = $(MODEL_FORMULATION) -D_MPI -DUNDERSCORE -DNAG_COMPILER" ) + +cray: # BUILDTARGET Cray Programming Environment + ( $(MAKE) all \ + "FC_PARALLEL = ftn" \ + "CC_PARALLEL = cc" \ + "CXX_PARALLEL = CC" \ + "FC_SERIAL = ftn" \ + "CC_SERIAL = cc" \ + "CXX_SERIAL = CC" \ + "FFLAGS_PROMOTION = -sreal64" \ + "FFLAGS_OPT = -Ofast -ffree" \ + "CFLAGS_OPT = -Ofast" \ + "CXXFLAGS_OPT = -Ofast" \ + "LDFLAGS_OPT = -Ofast -hbyteswapio" \ + "FFLAGS_DEBUG = -eD -O0 -ffree" \ + "CFLAGS_DEBUG = -O0 -g -Weverything" \ + "CXXFLAGS_DEBUG = -O0 -g -Weverything" \ + "LDFLAGS_DEBUG = -eD -O0 -hbyteswapio" \ + "FFLAGS_OMP = -homp" \ + "CFLAGS_OMP = -fopenmp" \ + "BUILD_TARGET = $(@)" \ + "CORE = $(CORE)" \ + "DEBUG = $(DEBUG)" \ + "USE_PAPI = $(USE_PAPI)" \ + "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 -check all -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 = + +ifneq "$(PIO)" "" +# +# Regardless of PIO library version, look for a lib subdirectory of PIO path +# NB: PIO_LIB is used later, so we don't just set LIBS directly +# +ifneq ($(wildcard $(PIO)/lib), ) + PIO_LIB = $(PIO)/lib else - CPPINCLUDES = -I$(PIO)/include - FCINCLUDES = -I$(PIO)/include - LIBS = -L$(PIO)/lib -lpio + PIO_LIB = $(PIO) endif +LIBS = -L$(PIO_LIB) + +# +# Regardless of PIO library version, look for an include subdirectory of PIO path +# +ifneq ($(wildcard $(PIO)/include), ) + CPPINCLUDES += -I$(PIO)/include + FCINCLUDES += -I$(PIO)/include else -ifeq "$(USE_PIO2)" "true" - FCINCLUDES = -I$(PIO)/include - override CPPFLAGS += -DUSE_PIO2 - LIBS = -L$(PIO) -lpiof -lpioc -ifneq ($(wildcard $(PIO)/libgptl.a), ) # Check for GPTL library for PIO2 - LIBS += -lgptl + CPPINCLUDES += -I$(PIO) + FCINCLUDES += -I$(PIO) endif -else - CPPINCLUDES = -I$(PIO) - FCINCLUDES = -I$(PIO) - LIBS = -L$(PIO) -lpio + +# +# Depending on PIO version, libraries may be libpio.a, or libpiof.a and libpioc.a +# Keep open the possibility of shared libraries in future with, e.g., .so suffix +# +# Check if libpio.* exists and link -lpio if so, but we make an exception for +# libpio.settings (a file added in PIO2), which is not a library to link +ifneq ($(wildcard $(PIO_LIB)/libpio\.*), ) + # Makefiles don't support "and" operators so we have nested "if" instead + ifneq "$(wildcard $(PIO_LIB)/libpio\.*)" "$(PIO_LIB)/libpio.settings" + LIBS += -lpio + endif +endif + +ifneq ($(wildcard $(PIO_LIB)/libpiof\.*), ) + LIBS += -lpiof +endif +ifneq ($(wildcard $(PIO_LIB)/libpioc\.*), ) + LIBS += -lpioc endif +ifneq ($(wildcard $(PIO_LIB)/libgptl\.*), ) + LIBS += -lgptl endif -ifneq "$(PNETCDF)" "" - CPPINCLUDES += -I$(PNETCDF)/include - FCINCLUDES += -I$(PNETCDF)/include - LIBS += -L$(PNETCDF)/lib -lpnetcdf +else # Not using PIO, using SMIOL + LIBS += -L$(PWD)/src/external/SMIOL -lsmiolf -lsmiol + FCINCLUDES += -I$(PWD)/src/external/SMIOL endif ifneq "$(NETCDF)" "" +ifneq ($(wildcard $(NETCDF)/lib/libnetcdf.*), ) + NETCDFLIBLOC = lib +endif +ifneq ($(wildcard $(NETCDF)/lib64/libnetcdf.*), ) + NETCDFLIBLOC = lib64 +endif CPPINCLUDES += -I$(NETCDF)/include FCINCLUDES += -I$(NETCDF)/include - LIBS += -L$(NETCDF)/lib + LIBS += -L$(NETCDF)/$(NETCDFLIBLOC) NCLIB = -lnetcdf NCLIBF = -lnetcdff - ifneq ($(wildcard $(NETCDF)/lib/libnetcdff.*), ) # CHECK FOR NETCDF4 + ifneq ($(wildcard $(NETCDF)/$(NETCDFLIBLOC)/libnetcdff.*), ) # CHECK FOR NETCDF4 LIBS += $(NCLIBF) endif # CHECK FOR NETCDF4 ifneq "$(NETCDFF)" "" FCINCLUDES += -I$(NETCDFF)/include - LIBS += -L$(NETCDFF)/lib + LIBS += -L$(NETCDFF)/$(NETCDFLIBLOC) LIBS += $(NCLIBF) endif LIBS += $(NCLIB) endif + +ifneq "$(PNETCDF)" "" +ifneq ($(wildcard $(PNETCDF)/lib/libpnetcdf.*), ) + PNETCDFLIBLOC = lib +endif +ifneq ($(wildcard $(PNETCDF)/lib64/libpnetcdf.*), ) + PNETCDFLIBLOC = lib64 +endif + CPPINCLUDES += -I$(PNETCDF)/include + FCINCLUDES += -I$(PNETCDF)/include + LIBS += -L$(PNETCDF)/$(PNETCDFLIBLOC) -lpnetcdf +endif + +ifneq "$(LAPACK)" "" + LIBS += -L$(LAPACK) + LIBS += -llapack + LIBS += -lblas +endif + RM = rm -f CPP = cpp -P -traditional RANLIB = ranlib @@ -539,14 +842,34 @@ ifeq "$(OPENMP)" "true" LDFLAGS += $(FFLAGS_OMP) endif #OPENMP IF -ifeq "$(PRECISION)" "single" +ifeq "$(OPENACC)" "true" + FFLAGS += $(FFLAGS_ACC) + CFLAGS += $(CFLAGS_ACC) + CXXFLAGS += $(CFLAGS_ACC) + override CPPFLAGS += "-DMPAS_OPENACC" + LDFLAGS += $(FFLAGS_ACC) +endif #OPENACC IF + +ifeq "$(OPENMP_OFFLOAD)" "true" + FFLAGS += $(FFLAGS_GPU) + CFLAGS += $(FFLAGS_GPU) + CXXFLAGS += $(FFLAGS_GPU) + override CPPFLAGS += "-DMPAS_OPENMP_OFFLOAD" + LDFLAGS += $(LDFLAGS_GPU) +endif #OPENMP_OFFLOAD IF + +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" @@ -558,11 +881,22 @@ else # USE_PAPI IF PAPI_MESSAGE="Papi libraries are off." endif # USE_PAPI IF -ifeq "$(USE_PIO2)" "true" - PIO_MESSAGE="Using the PIO 2 library." -else # USE_PIO2 IF - PIO_MESSAGE="Using the PIO 1.x library." -endif # USE_PIO2 IF +# Only if this Makefile was invoked from a compiler target should we check that PICFLAG is set +ifneq "$(FC_SERIAL)" "" +ifeq "$(SHAREDLIB)" "true" +ifneq "$(PICFLAG)" "" + FFLAGS += $(PICFLAG) + CFLAGS += $(PICFLAG) + CXXFLAGS += $(PICFLAG) + LDFLAGS += $(PICFLAG) + SHAREDLIB_MESSAGE="Position-independent code was generated." +else +$(error Position-independent code was requested but PIC flags are not available. Please add PIC flags for the '$(BUILD_TARGET)' target) +endif +else + SHAREDLIB_MESSAGE="Position-dependent code was generated." +endif +endif ifdef TIMER_LIB ifeq "$(TIMER_LIB)" "tau" @@ -612,28 +946,18 @@ else OPENMP_MESSAGE="MPAS was built without OpenMP support." endif -ifneq ($(wildcard .mpas_core_*), ) # CHECK FOR BUILT CORE - -ifneq ($(wildcard .mpas_core_$(CORE)), ) # CHECK FOR SAME CORE AS ATTEMPTED BUILD. - override AUTOCLEAN=false - CONTINUE=true -else - LAST_CORE=`cat .mpas_core_*` - -ifeq "$(AUTOCLEAN)" "true" # CHECK FOR CLEAN PRIOR TO BUILD OF A NEW CORE. - CONTINUE=true - AUTOCLEAN_MESSAGE="Infrastructure was cleaned prior to building ." +ifeq "$(OPENMP_OFFLOAD)" "true" + OPENMP_OFFLOAD_MESSAGE="MPAS was built with OpenMP-offload GPU support enabled." else - CONTINUE=false -endif # END OF AUTOCLEAN CHECK - -endif # END OF CORE=LAST_CORE CHECK + OPENMP_OFFLOAD_MESSAGE="MPAS was built without OpenMP-offload GPU support." +endif +ifeq "$(OPENACC)" "true" + OPENACC_MESSAGE="MPAS was built with OpenACC accelerator support enabled." else + OPENACC_MESSAGE="MPAS was built without OpenACC accelerator support." +endif - override AUTOCLEAN=false - CONTINUE=true -endif # END IF BUILT CORE CHECK ifneq ($(wildcard namelist.$(NAMELIST_SUFFIX)), ) # Check for generated namelist file. NAMELIST_MESSAGE="A default namelist file (namelist.$(NAMELIST_SUFFIX).defaults) has been generated, but namelist.$(NAMELIST_SUFFIX) has not been modified." @@ -676,9 +1000,12 @@ ifdef MPAS_EXTERNAL_CPPFLAGS endif #################################################### +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 @@ -687,16 +1014,123 @@ report_builds: @echo "CORE=$(CORE)" endif -ifeq "$(CONTINUE)" "true" all: mpas_main -else -all: clean_core + endif +# +# The rebuild_check target determines whether the shared framework or $(CORE) were +# previously compiled with incompatible options, and stops the build with an error +# message if so. +# +rebuild_check: + @# + @# Write current build options to a file .build_opts.tmp, to later be + @# compared with build options use for the shared framework or core. + @# Only build options that affect compatibility are written, while options + @# like $(RM), $(BUILD_TARGET), and $(CORE) are not. + @# + $(shell printf "FC=$(FC)\n$\ + CC=$(CC)\n$\ + CXX=$(CXX)\n$\ + SFC=$(SFC)\n$\ + SCC=$(SCC)\n$\ + CFLAGS=$(CFLAGS)\n$\ + CXXFLAGS=$(CXXFLAGS)\n$\ + FFLAGS=$(FFLAGS)\n$\ + LDFLAGS=$(LDFLAGS)\n$\ + CPPFLAGS=$(CPPFLAGS)\n$\ + LIBS=$(LIBS)\n$\ + CPPINCLUDES=$(CPPINCLUDES)\n$\ + OPENMP=$(OPENMP)\n$\ + OPENMP_OFFLOAD=$(OPENMP_OFFLOAD)\n$\ + OPENACC=$(OPENACC)\n$\ + TAU=$(TAU)\n$\ + PICFLAG=$(PICFLAG)\n$\ + TIMER_LIB=$(TIMER_LIB)\n$\ + GEN_F90=$(GEN_F90)\n" | sed 's/-DMPAS_EXE_NAME=[^[:space:]]*//' | sed 's/-DMPAS_NAMELIST_SUFFIX=[^[:space:]]*//' | sed 's/-DCORE_[^[:space:]]*//' | sed 's/-DMPAS_GIT_VERSION=[^[:space:]]*//' > .build_opts.tmp ) + + @# + @# PREV_BUILD is set to "OK" if the shared framework and core are either + @# clean or were previously compiled with compatible options. Otherwise, + @# PREV_BUILD is set to "shared framework" if the shared framework was + @# built with incompatible options, or "$(CORE) core" if the core was + @# built with incompatible options. + @# + $(eval PREV_BUILD := $(shell $\ + if [ -f ".build_opts.framework" ]; then $\ + cmp -s .build_opts.tmp .build_opts.framework; $\ + if [ $$? -eq 0 ]; then $\ + stat=0; $\ + else $\ + stat=1; $\ + x="shared framework"; $\ + if [ "$(AUTOCLEAN)" = "true" ]; then $\ + cp .build_opts.tmp .build_opts.framework; $\ + fi; $\ + fi $\ + else $\ + stat=0; $\ + cp .build_opts.tmp .build_opts.framework; $\ + fi; $\ + : ; $\ + : At this this point, stat is already set, and we should only ; $\ + : set it to 1 but never to 0, as that might mask an incompatibility ; $\ + : in the framework build. ; $\ + : ; $\ + if [ -f ".build_opts.$(CORE)" ]; then $\ + cmp -s .build_opts.tmp .build_opts.$(CORE); $\ + if [ $$? -ne 0 ]; then $\ + stat=1; $\ + if [ "$$x" = "" ]; then $\ + x="$(CORE) core"; $\ + else $\ + x="$$x and $(CORE) core"; $\ + fi; $\ + if [ "$(AUTOCLEAN)" = "true" ]; then $\ + cp .build_opts.tmp .build_opts.$(CORE); $\ + fi; $\ + fi; $\ + else $\ + if [ $$stat -eq 0 ]; then $\ + cp .build_opts.tmp .build_opts.$(CORE); $\ + fi; $\ + fi; $\ + rm -f .build_opts.tmp; $\ + if [ $$stat -eq 1 ]; then $\ + printf "$$x"; $\ + else $\ + printf "OK"; $\ + fi; $\ + )) + + $(if $(findstring and,$(PREV_BUILD)),$(eval VERB=were),$(eval VERB=was)) +ifeq "$(AUTOCLEAN)" "true" + $(if $(findstring framework,$(PREV_BUILD)),$(eval AUTOCLEAN_DEPS+=clean_shared)) + $(if $(findstring core,$(PREV_BUILD)),$(eval AUTOCLEAN_DEPS+=clean_core)) + $(if $(findstring OK,$(PREV_BUILD)), $(eval override AUTOCLEAN=false), ) + $(eval AUTOCLEAN_MESSAGE=The $(PREV_BUILD) $(VERB) cleaned and re-compiled.) +else + $(if $(findstring OK,$(PREV_BUILD)), \ + , \ + $(info ************************************************************************) \ + $(info The $(PREV_BUILD) $(VERB) previously compiled with ) \ + $(info incompatible options. Please do one of the following:) \ + $(info ) \ + $(info - Clean the $(CORE) core, which will also cause the shared) \ + $(info framework to be cleaned; then compile the $(CORE) core.) \ + $(info ) \ + $(info or)\ + $(info ) \ + $(info - Add AUTOCLEAN=true to the build command to automatically clean) \ + $(info and re-compile the $(PREV_BUILD).) \ + $(info ) \ + $(info ************************************************************************) \ + $(error )) endif -compiler_test: +openmp_test: ifeq "$(OPENMP)" "true" @echo "Testing compiler for OpenMP support" @echo "#include " > conftest.c; echo "int main() { int n = omp_get_num_threads(); return 0; }" >> conftest.c; $(SCC) $(CFLAGS) -o conftest.out conftest.c || \ @@ -713,10 +1147,243 @@ ifeq "$(OPENMP)" "true" endif -mpas_main: compiler_test -ifeq "$(AUTOCLEAN)" "true" - $(RM) .mpas_core_* +openacc_test: +ifeq "$(OPENACC)" "true" + @# + @# First ensure that both FFLAGS_ACC and CFLAGS_ACC are not blank + @# If these are not set for a target, then OpenACC most likely cannot compile + @# + @echo "Checking if FFLAGS_ACC and CFLAGS_ACC are defined for [$(BUILD_TARGET)]..." + @( if ([ -z "$(FFLAGS_ACC)" ] && [ -z "$(CFLAGS_ACC)" ]); then \ + echo "*********************************************************"; \ + echo "ERROR: OPENACC=true was specified, but [$(BUILD_TARGET)] build target does not seem to support OpenACC:"; \ + echo " FFLAGS_ACC and CFLAGS_ACC are both undefined for [$(BUILD_TARGET)] in the top-level Makefile."; \ + echo "Please set these variables to appropriate OpenACC compilation flags in the [$(BUILD_TARGET)] target to enable OpenACC support."; \ + echo "*********************************************************"; exit 1; \ + else \ + echo "=> FFLAGS_ACC or CFLAGS_ACC are defined"; \ + fi ) + + @# + @# Create test C and Fortran programs that look for OpenACC header file and parallelize a loop + @# + @printf "#include \n\ + &int main(){\n\ + & int n_devs=acc_get_num_devices( acc_device_default );\n\ + & int i,n=0;\n\ + & #pragma acc kernels\n\ + & for (i=0; i<10; i++)\n\ + & n=n+i;\n\ + & return 0;\n\ + &}\n" | sed 's/^ *&//' > openacc.c + @printf "program openacc\n\ + & use openacc\n\ + & integer :: i,n=0,n_devs=0\n\ + & n_devs=acc_get_num_devices( acc_device_default )\n\ + & !\$$acc kernels\n\ + & do i=0,10\n\ + & n=n+i\n\ + & end do\n\ + & !\$$acc end kernels\n\ + &end program\n" | sed 's/^ *&//' > openacc.f90 + + @# + @# See whether the test programs can be compiled + @# + @echo "Checking [$(BUILD_TARGET)] compilers for OpenACC support..." + @( $(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) -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) -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) -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) -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) -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) -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) -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) -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) -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 ) + + @rm -f openacc.c openacc.f90 openacc_[cf].out openacc_[cf].log +endif # OPENACC eq true + + +pio_test: openmp_test openacc_test + @# + @# PIO_VERS will be set to: + @# 0 if no working PIO library was detected (and .piotest.log will contain error messages) + @# 1 if a PIO 1.x library was detected + @# 2 if a PIO 2.x library was detected + @# + $(info Checking for a working PIO library...) +ifneq "$(USE_PIO2)" "" + $(info *** Note: The USE_PIO2 option has been deprecated and will be ignored.) +endif + $(eval PIO_VERS := $(shell $\ + rm -f .piotest.log; $\ + printf "program pio1\n$\ + & use pio\n$\ + & use pionfatt_mod\n$\ + & integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET\n$\ + & integer, parameter :: MPAS_INT_FILLVAL = NF_FILL_INT\n$\ + & type (Var_desc_t) :: field_desc\n$\ + & integer (kind=MPAS_IO_OFFSET_KIND) :: frame_number\n$\ + & call PIO_setframe(field_desc, frame_number)\n$\ + end program\n" | sed 's/&/ /' > pio1.f90; $\ + $\ + printf "program pio2\n$\ + & use pio\n$\ + & integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET_KIND\n$\ + & integer, parameter :: MPAS_INT_FILLVAL = PIO_FILL_INT\n$\ + & type (file_desc_t) :: pio_file\n$\ + & type (Var_desc_t) :: field_desc\n$\ + & integer (kind=MPAS_IO_OFFSET_KIND) :: frame_number\n$\ + & call PIO_setframe(pio_file, field_desc, frame_number)\n$\ + end program\n" | sed 's/&/ /' > pio2.f90; $\ + $\ + $(FC) pio1.f90 -o pio1.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) > /dev/null 2>&1; $\ + pio1_status=$$?; $\ + $\ + $(FC) pio2.f90 -o pio2.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS) > /dev/null 2>&1; $\ + pio2_status=$$?; $\ + $\ + if [ $$pio1_status -ne 0 -a $$pio2_status -ne 0 ]; then $\ + printf "0"; $\ + printf "*********************************************************\n" > .piotest.log; $\ + printf "ERROR: Could not detect a working PIO library!\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "Both of the following commands to compile a test program\n" >> .piotest.log; $\ + printf "failed with errors:\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "$(FC) pio1.f90 -o pio1.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS)\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "$(FC) pio2.f90 -o pio2.x $(FCINCLUDES) $(FFLAGS) $(LDFLAGS) $(LIBS)\n" >> .piotest.log; $\ + printf "\n" >> .piotest.log; $\ + printf "The pio1.f90 and pio2.f90 test programs have been left in\n" >> .piotest.log; $\ + printf "the top-level MPAS directory for further debugging.\n" >> .piotest.log; $\ + printf "*********************************************************\n" >> .piotest.log; $\ + elif [ $$pio1_status -eq 0 ]; then $\ + printf "1"; $\ + rm -f pio[12].f90 pio[12].x; $\ + elif [ $$pio2_status -eq 0 ]; then $\ + printf "2"; $\ + rm -f pio[12].f90 pio[12].x; $\ + fi $\ + )) + $(if $(findstring 1,$(PIO_VERS)), $(eval IO_MESSAGE = "Using the PIO 1.x library."), ) + $(if $(findstring 1,$(PIO_VERS)), $(info PIO 1.x detected.)) + $(if $(findstring 2,$(PIO_VERS)), $(eval override CPPFLAGS += -DUSE_PIO2), ) + $(if $(findstring 2,$(PIO_VERS)), $(eval IO_MESSAGE = "Using the PIO 2.x library."), ) + $(if $(findstring 2,$(PIO_VERS)), $(info PIO 2.x detected.)) + @# + @# A .piotest.log file exists iff no working PIO library was detected + @# + @if [ -f .piotest.log ]; then \ + cat .piotest.log; \ + rm -f .piotest.log; \ + 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, MPI_INTEGER, MPI_Datatype\n$\ + & integer :: ierr\n$\ + & type (MPI_Comm) :: comm\n$\ + & type (MPI_Datatype), parameter :: MPI_INTEGERKIND = MPI_INTEGER\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 = rebuild_check openmp_test openacc_test pio_test mpi_f08_test +override CPPFLAGS += "-DMPAS_PIO_SUPPORT" +else +MAIN_DEPS = rebuild_check openmp_test openacc_test mpi_f08_test +IO_MESSAGE = "Using the SMIOL library." +override CPPFLAGS += "-DMPAS_SMIOL_SUPPORT" endif + +mpas_main: $(MAIN_DEPS) cd src; $(MAKE) FC="$(FC)" \ CC="$(CC)" \ CXX="$(CXX)" \ @@ -735,33 +1402,39 @@ endif FCINCLUDES="$(FCINCLUDES)" \ CORE="$(CORE)"\ AUTOCLEAN="$(AUTOCLEAN)" \ + AUTOCLEAN_DEPS="$(AUTOCLEAN_DEPS)" \ GEN_F90="$(GEN_F90)" \ NAMELIST_SUFFIX="$(NAMELIST_SUFFIX)" \ EXE_NAME="$(EXE_NAME)" - @echo "$(EXE_NAME)" > .mpas_core_$(CORE) if [ -e src/$(EXE_NAME) ]; then mv src/$(EXE_NAME) .; fi ( cd src/core_$(CORE); $(MAKE) ROOT_DIR="$(PWD)" post_build ) @echo "*******************************************************************************" @echo $(PRECISION_MESSAGE) @echo $(DEBUG_MESSAGE) @echo $(PARALLEL_MESSAGE) + @echo $(MPI_F08_MESSAGE) @echo $(PAPI_MESSAGE) @echo $(TAU_MESSAGE) @echo $(OPENMP_MESSAGE) + @echo $(OPENMP_OFFLOAD_MESSAGE) + @echo $(OPENACC_MESSAGE) + @echo $(SHAREDLIB_MESSAGE) ifeq "$(AUTOCLEAN)" "true" @echo $(AUTOCLEAN_MESSAGE) endif @echo $(GEN_F90_MESSAGE) @echo $(TIMER_MESSAGE) - @echo $(PIO_MESSAGE) + @echo $(IO_MESSAGE) @echo "*******************************************************************************" clean: - cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" - $(RM) .mpas_core_* + cd src; $(MAKE) clean RM="$(RM)" CORE="$(CORE)" AUTOCLEAN="$(AUTOCLEAN)" $(RM) $(EXE_NAME) $(RM) namelist.$(NAMELIST_SUFFIX).defaults $(RM) streams.$(NAMELIST_SUFFIX).defaults + if [ -f .build_opts.framework ]; then $(RM) .build_opts.framework; fi + if [ -f .build_opts.$(CORE) ]; then $(RM) .build_opts.$(CORE); fi + core_error: @echo "" @echo "*******************************************************************************" @@ -772,31 +1445,10 @@ core_error: exit 1 error: errmsg -clean_core: - @echo "" - @echo "*******************************************************************************" - @echo " The MPAS infrastructure is currently built for the $(LAST_CORE) core." - @echo " Before building the $(CORE) core, please do one of the following." - @echo "" - @echo "" - @echo " To remove the $(LAST_CORE)_model executable and clean the MPAS infrastructure, run:" - @echo " make clean CORE=$(LAST_CORE)" - @echo "" - @echo " To preserve all executables except $(CORE)_model and clean the MPAS infrastructure, run:" - @echo " make clean CORE=$(CORE)" - @echo "" - @echo " Alternatively, AUTOCLEAN=true can be appended to the make command to force a clean," - @echo " build a new $(CORE)_model executable, and preserve all other executables." - @echo "" - @echo "*******************************************************************************" - @echo "" - exit 1 - else # CORE IF all: error -clean: errmsg - exit 1 +clean: error error: errmsg @echo "************ ERROR ************" @echo "No CORE specified. Quitting." @@ -810,11 +1462,8 @@ errmsg: @echo "" @echo "Usage: $(MAKE) target CORE=[core] [options]" @echo "" - @echo "Example targets:" - @echo " ifort" - @echo " gfortran" - @echo " xlf" - @echo " pgi" + @echo "Available Targets:" + @grep BUILDTARGET Makefile | grep -v grep | sed -e 's/#[[:blank:]]*BUILDTARGET[[:blank:]]*/#/' | sed -e 's/:[[:blank:]]*#/:#/' | sed -e 's/://' | awk 'BEGIN {FS="#"}{printf (" %-15s - %s\n", $$1, $$2)}' @echo "" @echo "Availabe Cores:" @cd src; ls -d core_* | grep ".*" | sed "s/core_/ /g" @@ -823,15 +1472,16 @@ errmsg: @echo " DEBUG=true - builds debug version. Default is optimized version." @echo " USE_PAPI=true - builds version using PAPI for timers. Default is off." @echo " TAU=true - builds version using TAU hooks for profiling. Default is off." - @echo " AUTOCLEAN=true - forces a clean of infrastructure prior to build new core." + @echo " AUTOCLEAN=true - Enables automatic cleaning and re-compilation of code as needed." @echo " GEN_F90=true - Generates intermediate .f90 files through CPP, and builds with them." @echo " TIMER_LIB=opt - Selects the timer library interface to be used for profiling the model. Options are:" @echo " TIMER_LIB=native - Uses native built-in timers in MPAS" @echo " TIMER_LIB=gptl - Uses gptl for the timer interface instead of the native interface" @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 " USE_PIO2=true - links with the PIO 2 library. Default is to use the PIO 1.x library." - @echo " PRECISION=single - builds with default single-precision real kind. Default is to use double-precision." + @echo " OPENACC=true - builds and links with OpenACC flags. Default is to not use OpenACC." + @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" @echo "that point to the absolute paths for the libraries." diff --git a/README.md b/README.md index 138deec514..b62228420a 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -MPAS-v6.1 +MPAS-v8.2.1 ==== The Model for Prediction Across Scales (MPAS) is a collaborative project for @@ -43,14 +43,17 @@ only described below the src directory. MPAS-Model ├── src - │   ├── registry -- Code for building Registry.xml parser (Shared) │   ├── driver -- Main driver for MPAS in stand-alone mode (Shared) │   ├── external -- External software for MPAS (Shared) │   ├── framework -- MPAS Framework (Includes DDT Descriptions, and shared routines. Shared) │   ├── operators -- MPAS Opeartors (Includes Operators for MPAS meshes. Shared) - │   ├── inc -- Empty directory for include files that Registry generates (Shared) + │   ├── tools -- Empty directory for include files that Registry generates (Shared) + │   │  ├── registry -- Code for building Registry.xml parser (Shared) + │  │  └── input_gen -- Code for generating streams and namelist files (Shared) │   └── core_* -- Individual model cores. - └────── testing_and_setup -- tools for setting up configurations and tests cases (Shared) + │   └── inc -- Empty directory for include files that Registry generates + ├── testing_and_setup -- Tools for setting up configurations and test cases (Shared) + └── default_inputs -- Copies of default stream and namelists files (Shared) Model cores are typically developed independently. For information about building and running a particular core, please refer to that core's user's diff --git a/cmake/Functions/MPAS_Functions.cmake b/cmake/Functions/MPAS_Functions.cmake new file mode 100644 index 0000000000..42127af00b --- /dev/null +++ b/cmake/Functions/MPAS_Functions.cmake @@ -0,0 +1,247 @@ +## +# get_mpas_version( ) +# +# Extracts the MPAS-Model project's version from the README.md file. +# The extracted version is a string following the format "X.Y.Z", where +# "X", "Y", and "Z" correspond to the major, minor, and patch versions +# respectively. +# +# Precondition: +# * README.md file needs to be in the current source directory. +# * README.md file should contain the project version formatted +# as "MPAS-vX.Y.Z". +# +# Postcondition: +# * If a match is found, will contain the version string, +# else it will be empty. +# +# Args: +# - The name of the variable that will hold the extracted version +# string. +# +# Example usage: +# get_mpas_version(MPAS_VERSION) +# message("MPAS Version: ${MPAS_VERSION}") +## +function(get_mpas_version mpas_version) + file(READ "${CMAKE_CURRENT_SOURCE_DIR}/README.md" readme_contents) + string(REGEX MATCH "MPAS-v([0-9]+\\.[0-9]+\\.[0-9]+)" _ ${readme_contents}) + set(${mpas_version} ${CMAKE_MATCH_1} PARENT_SCOPE) +endfunction() + +## +# get_git_version( ) +# Extracts the current Git version of the project. +# will contain the Git version string. +# Example usage: +# get_git_version(GIT_VERSION) +# message("Git Version: ${GIT_VERSION}") +## + + +function(get_git_version git_version) + execute_process( + COMMAND git describe --tags --always + WORKING_DIRECTORY ${CMAKE_CURRENT_SOURCE_DIR} + RESULT_VARIABLE RESULT + OUTPUT_VARIABLE GIT_VERSION + OUTPUT_STRIP_TRAILING_WHITESPACE + ) + + if(NOT RESULT EQUAL 0) + message(WARNING "Failed to get Git version!") + endif() + set(${git_version} ${GIT_VERSION} PARENT_SCOPE + ) +endfunction() + + +## +# mpas_fortran_target( ) +# +# Fortran configuration and options common to all MPAS Fortran targets +# +# * Installs common Fortan modules to a per-compiler-version directory +# * General Fortran formatting and configuration options +# * Per-compiler configuration and options +# * MPAS_DOUBLE_PRECISION related flags +# +# Args: +# - The name of the target to prepare +# + +function(mpas_fortran_target target) + # Fortran modules include path + set_target_properties(${target} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/${MPAS_MODULE_DIR}) + target_include_directories(${target} INTERFACE $ + $) + #Relocatable, portable, runtime dynamic linking + set_target_properties(${target} PROPERTIES INSTALL_RPATH "\$ORIGIN/../${CMAKE_INSTALL_LIBDIR}") + + # Global Fortran configuration + set_target_properties(${target} PROPERTIES Fortran_FORMAT FREE) + set(MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS + _MPI=1 + USE_PIO2=1 + ) + # Enable OpenMP support + if(MPAS_OPENMP) + target_link_libraries(${target} PUBLIC OpenMP::OpenMP_Fortran) + endif() + + # Compiler-specific options and flags + if(CMAKE_Fortran_COMPILER_ID MATCHES GNU) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-ffree-line-length-none> + ) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC + $<$:-fconvert=big-endian> + ) + + if(CMAKE_Fortran_COMPILER_VERSION VERSION_GREATER_EQUAL 10) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-fallow-argument-mismatch> + $<$:-fallow-invalid-boz> + ) + endif() + if(MPAS_DOUBLE_PRECISION) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-fdefault-real-8> $<$:-fdefault-double-8> + ) + else() + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS SINGLE_PRECISION) + endif() + elseif(CMAKE_Fortran_COMPILER_ID MATCHES Intel) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC + $<$:-align array64byte> + $<$:-convert big_endian> + ) + if(MPAS_DOUBLE_PRECISION) + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE + $<$:-real-size 64> + ) + else() + list(APPEND MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS SINGLE_PRECISION) + endif() + endif() + target_compile_definitions(${target} PRIVATE ${MPAS_FORTRAN_TARGET_COMPILE_DEFINITIONS}) + target_compile_options(${target} PRIVATE ${MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PRIVATE}) + target_compile_options(${target} PUBLIC ${MPAS_FORTRAN_TARGET_COMPILE_OPTIONS_PUBLIC}) +endfunction() + + +# mpas_core_target(CORE TARGET INCLUDE ) +# +# Common configuration and properties for `MPAS::core::` targets. +# * Calls mpas_fortran_target() for common Fortran target configuration. +# * Installs Fortran modules to a per-core directory and adds target include directories +# appropriate for build and install trees. +# * XML Processing, parsing and generation of includes, namelists and streams +# * Each core uses a core-specific parser executable +# * Links to MPAS::framework and MPAS::operators +# * Exports MPAS::core:: target alias for use by external dependencies +# * Installs core libraries modules and generated files. +# +# Args: +# CORE - Name of core +# TARGET - Name of core_target (without namespace) +# INCLUDES - List of generated include files +# +function(mpas_core_target) + cmake_parse_arguments(ARG "" "CORE;TARGET" "INCLUDES" ${ARGN}) + + mpas_fortran_target(${ARG_TARGET}) + + set_property(TARGET ${ARG_TARGET} APPEND PROPERTY SOURCES ${MPAS_SUBDRIVER_SRC}) + + string(TOUPPER "${ARG_TARGET}" TARGET) + set_target_properties(${ARG_TARGET} PROPERTIES OUTPUT_NAME mpas_${ARG_CORE}) + + #Fortran modules output location + set(CORE_MODULE_DIR ${MPAS_MODULE_DIR}/${ARG_TARGET}) + set_target_properties(${ARG_TARGET} PROPERTIES Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}/${CORE_MODULE_DIR}) + target_include_directories(${ARG_TARGET} INTERFACE $ + $) + + #MPAS Specific option + target_compile_definitions(${ARG_TARGET} PRIVATE ${TARGET}=1) + + #Generated includes are included from either ./inc/ or ./ so we create a symlink in the build directory + #To handle the inc/ variety (sw, test, seaice) uniformly with the ./ variety (atmosphere, init_atmosphere) + add_custom_target(${ARG_CORE}_include_link ALL + COMMAND ${CMAKE_COMMAND} -E create_symlink ${CMAKE_CURRENT_BINARY_DIR} ${CMAKE_CURRENT_BINARY_DIR}/inc) + add_dependencies(${ARG_TARGET} ${ARG_CORE}_include_link) + target_include_directories(${ARG_TARGET} PUBLIC $) + + #Core-independent library dependencies + target_link_libraries(${ARG_TARGET} PUBLIC ${PROJECT_NAME}::operators ${PROJECT_NAME}::framework) + + #Define alias for external use + add_library(${PROJECT_NAME}::core::${ARG_CORE} ALIAS ${ARG_TARGET}) + + #Create main executable + add_executable(mpas_${ARG_CORE} ${MPAS_MAIN_SRC}) + mpas_fortran_target(mpas_${ARG_CORE}) + target_link_libraries(mpas_${ARG_CORE} PUBLIC ${PROJECT_NAME}::core::${ARG_CORE}) + + #Per-core generated output and tables directory location + set(CORE_DATADIR ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/${ARG_TARGET}) + file(MAKE_DIRECTORY ${CORE_DATADIR}) + + #Process registry and generate includes, namelists, and streams + get_git_version(git_version) + string(TOUPPER ${ARG_CORE} ARG_CORE_UPPER) + set(CPP_EXTRA_FLAGS ${CPP_EXTRA_FLAGS} -DCORE_${ARG_CORE_UPPER} -DMPAS_NAMELIST_SUFFIX=${ARG_CORE} -DMPAS_EXE_NAME=mpas_${ARG_CORE} -DMPAS_GIT_VERSION=${git_version} -DMPAS_BUILD_TARGET=${CMAKE_Fortran_COMPILER_ID}) + message("CPP_EXTRA_FLAGS: ${CPP_EXTRA_FLAGS}") + if (${DO_PHYSICS}) + set(CPP_EXTRA_FLAGS ${CPP_EXTRA_FLAGS} -DDO_PHYSICS) + endif() + +add_custom_command(OUTPUT Registry_processed.xml + COMMAND ${CPP_EXECUTABLE} -E -P ${CPP_EXTRA_FLAGS} ${CMAKE_CURRENT_SOURCE_DIR}/Registry.xml > Registry_processed.xml + COMMENT "CORE ${ARG_CORE}: Pre-Process Registry" + DEPENDS Registry.xml) + add_custom_command(OUTPUT ${ARG_INCLUDES} + COMMAND mpas_parse_${ARG_CORE} Registry_processed.xml ${CPP_EXTRA_FLAGS} + COMMENT "CORE ${ARG_CORE}: Parse Registry" + DEPENDS mpas_parse_${ARG_CORE} Registry_processed.xml) + add_custom_command(OUTPUT namelist.${ARG_CORE} + WORKING_DIRECTORY ${CORE_DATADIR} + COMMAND mpas_namelist_gen ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml namelist.${ARG_CORE} in_defaults=true + COMMENT "CORE ${ARG_CORE}: Generate Namelist" + DEPENDS mpas_namelist_gen Registry_processed.xml) + add_custom_command(OUTPUT streams.${ARG_CORE} + WORKING_DIRECTORY ${CORE_DATADIR} + COMMAND mpas_streams_gen ${CMAKE_CURRENT_BINARY_DIR}/Registry_processed.xml streams.${ARG_CORE} stream_list.${ARG_CORE}. listed + COMMENT "CORE ${ARG_CORE}: Generate Streams" + DEPENDS mpas_streams_gen Registry_processed.xml) + add_custom_target(gen_${ARG_CORE} DEPENDS ${ARG_INCLUDES} namelist.${ARG_CORE} streams.${ARG_CORE}) + add_dependencies(${ARG_TARGET} gen_${ARG_CORE}) + + #Install data and target library and executable + install(DIRECTORY ${CORE_DATADIR}/ DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}/${ARG_TARGET} + FILES_MATCHING PATTERN "namelist.*" PATTERN "streams.*" PATTERN "stream_list.*" ) + install(TARGETS ${ARG_TARGET} EXPORT ${PROJECT_NAME}ExportsCore + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) + install(TARGETS mpas_${ARG_CORE} + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) +endfunction() + +## +# set_MPAS_DEBUG_flag( ) +# +# Sets the MPAS_DEBUG compile definition for a given target when the build type is Debug. +# +# Args: +# - The target for which the compile definition will be set +# +# Usage example: +# set_MPAS_DEBUG_flag(TARGET) +# This will define MPAS_DEBUG for the target TARGET during a Debug build +## +function(set_MPAS_DEBUG_flag target) + if(CMAKE_BUILD_TYPE MATCHES Debug) + target_compile_definitions(${target} PRIVATE MPAS_DEBUG) + endif() +endfunction() \ No newline at end of file diff --git a/cmake/Modules/FindGPTL.cmake b/cmake/Modules/FindGPTL.cmake new file mode 100644 index 0000000000..8e8014c337 --- /dev/null +++ b/cmake/Modules/FindGPTL.cmake @@ -0,0 +1,175 @@ +# FindGPTL.cmake +# +# Copyright UCAR 2020 +# +# Find the GPTL: General Purpose Timing Library (https://jmrosinski.github.io/GPTL/) +# +# This find module sets the following variables and targets: +# +# Variables: +# GPTL_FOUND - True if GPTL was found +# GPTL_VERSION_STRING - Version of installed GPTL +# GPTL_BIN_DIR - GPTL binary directory +# GPTL_HAS_PKG_CONFIG - GPTL was found with installed `gptl.pc` and pkg-config. This indicates full support +# for compiler and linker flags as exported by GPTL. +# Targets: +# GPTL::GPTL - Imported interface target to pass to target_link_libraries() +# +# NOTE: This find modules uses `pkg-config` to locate GPTL and glean the appropriate flags, directories, +# and link dependency ordering. For this to work, both a `pkg-config` executable and a `gptl.pc` +# config file need to be found. +# * To find the `pkg-config` executable, ensure it is on your PATH. +# * For non-standard locations the official CMake FindPkgConfig uses Cmake variable `PKG_CONFIG_EXECUTABLE` +# or environment variable `PKG_CONFIG`. See: https://cmake.org/cmake/help/latest/module/FindPkgConfig.html +# * To find `gptl.pc` ensure it is on the (colon-separated) directories listed in standard pkg-config +# environment variable `PKG_CONFIG_PATH`. +# * See: https://linux.die.net/man/1/pkg-config +# * A working GPTL pkg-config install can be confirmed on the command line, e.g., +# ``` +# $ pkg-config --modversion gptl +# 8.0.2 +# ``` +# To set a non-standard location for GPTL, ensure the correct `gptl.pc` pkg config file is found first +# on the environment's `PKG_CONFIG_PATH`. This can be checked with the pkg-config executable, e.g., +# ``` +# $ pkg-config --variable=prefix gptl +# /usr/local +# ``` +# Only when pkg-config is not supported or available, GPTL will be searched by the standard CMake search procedures. +# Set environment or CMake variable GPTL_ROOT to control this search. The GPTL_ROOT variable will have no effect +# if GPTL_HAS_PKG_CONFIG=True. +# + +find_package(PkgConfig QUIET) +if(PKG_CONFIG_FOUND) + message(DEBUG "[FindGPTL] Using PKG_CONFIG_EXECUTABLE:${PKG_CONFIG_EXECUTABLE}") +endif() + +#Helper: +#check_pkg_config(ret_var pcname pcflags...) +# Check if pcname is known to pkg-config +# Returns: +# Boolean: true if ${pcname}.pc file is found by pkg-config). +# Args: +# ret_var: return variable name. +# pcname: pkg-config name to look for (.pc file) +function(check_pkg_config ret_var pcname) + if(NOT PKG_CONFIG_FOUND OR NOT EXISTS ${PKG_CONFIG_EXECUTABLE}) + set(${ret_var} False PARENT_SCOPE) + else() + execute_process(COMMAND ${PKG_CONFIG_EXECUTABLE} --exists ${pcname} RESULT_VARIABLE _found) + if(_found EQUAL 0) + set(${ret_var} True PARENT_SCOPE) + else() + set(${ret_var} False PARENT_SCOPE) + endif() + endif() +endfunction() + +#Helper: +#get_pkg_config(ret_var pcname pcflags...) +# Get the output of pkg-config +# Args: +# ret_var: return variable name +# pcname: pkg-config name to look for (.pc file) +# pcflags: pkg-config flags to pass +function(get_pkg_config ret_var pcname pcflags) + execute_process(COMMAND ${PKG_CONFIG_EXECUTABLE} ${ARGN} ${pcname} ${pcflags} OUTPUT_VARIABLE _out RESULT_VARIABLE _ret OUTPUT_STRIP_TRAILING_WHITESPACE) + if(_ret EQUAL 0) + separate_arguments(_out) + set(${ret_var} ${_out} PARENT_SCOPE) + else() + set(${ret_var} "" PARENT_SCOPE) + endif() +endfunction() + +check_pkg_config(GPTL_HAS_PKG_CONFIG gptl) +if(GPTL_HAS_PKG_CONFIG) + #Use pkg-config to find the prefix, flags, directories, executables, and libraries + get_pkg_config(GPTL_VERSION_STRING gptl --modversion) + get_pkg_config(GPTL_PREFIX gptl --variable=prefix) + get_pkg_config(GPTL_INCLUDE_DIR gptl --cflags-only-I) + if(EXISTS GPTL_INCLUDE_DIR) + string(REGEX REPLACE "-I([^ ]+)" "\\1;" GPTL_INCLUDE_DIR ${GPTL_INCLUDE_DIR}) #Remove -I + else() + find_path(GPTL_INCLUDE_DIR NAMES gptl.h PATH_SUFFIXES include include/gptl PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) + endif() + find_path(GPTL_MODULE_DIR NAMES gptl.mod PATH_SUFFIXES include include/gptl module module/gptl PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) + get_pkg_config(GPTL_COMPILE_OPTIONS gptl --cflags-only-other) + get_pkg_config(GPTL_LINK_LIBRARIES gptl --libs-only-l) + get_pkg_config(GPTL_LINK_DIRECTORIES gptl --libs-only-L) + if(GPTL_LINK_DIRECTORIES) + string(REGEX REPLACE "-L([^ ]+)" "\\1;" GPTL_LINK_DIRECTORIES ${GPTL_LINK_DIRECTORIES}) #Remove -L + endif() + get_pkg_config(GPTL_LINK_OPTIONS gptl --libs-only-other) + find_library(GPTL_LIBRARY NAMES gptl PATH_SUFFIXES lib lib64 PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) + find_path(GPTL_BIN_DIR NAMES gptl_avail PATH_SUFFIXES bin PATHS ${GPTL_PREFIX} NO_DEFAULT_PATH) +else() + #Attempt to find GPTL without pkg-config as last resort. + message(WARNING "\ +FindGPTL: The `pkg-config` executable was not found. Ensure it is on your path or set \ +environment variable PKG_CONFIG to your pkg-config executable. \ +Attempting to find GPTL without pkg-config support may cause some required compiler and linker options to be unset.") + + find_path(GPTL_INCLUDE_DIR NAMES gptl.h PATH_SUFFIXES include include/gptl) + find_path(GPTL_MODULE_DIR NAMES gptl.mod PATH_SUFFIXES include include/gptl module module/gptl) + find_library(GPTL_LIBRARY NAMES gptl PATH_SUFFIXES lib lib64) + find_path(GPTL_BIN_DIR NAMES gptl_avail PATH_SUFFIXES bin) +endif() + +#Hide non-documented cache variables reserved for internal/advanced usage +mark_as_advanced( GPTL_INCLUDE_DIR + GPTL_MODULE_DIR + GPTL_LIBRARY ) + +#Debugging output +message(DEBUG "[FindGPTL] GPTL_FOUND: ${GPTL_FOUND}") +message(DEBUG "[FindGPTL] GPTL_VERSION_STRING: ${GPTL_VERSION_STRING}") +message(DEBUG "[FindGPTL] GPTL_HAS_PKG_CONFIG: ${GPTL_HAS_PKG_CONFIG}") +message(DEBUG "[FindGPTL] GPTL_PREFIX: ${GPTL_PREFIX}") +message(DEBUG "[FindGPTL] GPTL_BIN_DIR: ${GPTL_BIN_DIR}") +message(DEBUG "[FindGPTL] GPTL_INCLUDE_DIR: ${GPTL_INCLUDE_DIR}") +message(DEBUG "[FindGPTL] GPTL_MODULE_DIR: ${GPTL_MODULE_DIR}") +message(DEBUG "[FindGPTL] GPTL_LIBRARY: ${GPTL_LIBRARY}") +message(DEBUG "[FindGPTL] GPTL_LINK_LIBRARIES: ${GPTL_LINK_LIBRARIES}") +message(DEBUG "[FindGPTL] GPTL_LINK_DIRECTORIES: ${GPTL_LINK_DIRECTORIES}") +message(DEBUG "[FindGPTL] GPTL_LINK_OPTIONS: ${GPTL_LINK_OPTIONS}") + +#Check package has been found correctly +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + GPTL + REQUIRED_VARS + GPTL_LIBRARY + GPTL_INCLUDE_DIR + GPTL_MODULE_DIR + GPTL_BIN_DIR + VERSION_VAR + GPTL_VERSION_STRING +) + +#Create GPTL::GPTL imported interface target +if(GPTL_FOUND AND NOT TARGET GPTL::GPTL) + add_library(GPTL::GPTL INTERFACE IMPORTED) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${GPTL_INCLUDE_DIR}) + if(GPTL_MODULE_DIR) + set_property(TARGET GPTL::GPTL APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${GPTL_MODULE_DIR}) + endif() + if(GPTL_COMPILE_OPTIONS) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_COMPILE_OPTIONS ${GPTL_COMPILE_OPTIONS}) + endif() + if(GPTL_LINK_DIRECTORIES) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_DIRECTORIES ${GPTL_LINK_DIRECTORIES}) + endif() + if(GPTL_LINK_OPTIONS) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_OPTIONS ${GPTL_LINK_OPTIONS}) + endif() + if(GPTL_LINK_LIBRARIES) + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_LIBRARIES ${GPTL_LINK_LIBRARIES}) + else() + set_property(TARGET GPTL::GPTL PROPERTY INTERFACE_LINK_LIBRARIES ${GPTL_LIBRARY}) + get_filename_component(_lib_dir ${GPTL_LIBRARY} DIRECTORY) + set_property(TARGET GPTL::GPTL APPEND PROPERTY INTERFACE_LINK_DIRECTORIES ${_lib_dir}) + unset(_lib_dir) + endif() +endif() diff --git a/cmake/Modules/FindNetCDF.cmake b/cmake/Modules/FindNetCDF.cmake new file mode 100644 index 0000000000..f2fc6ac514 --- /dev/null +++ b/cmake/Modules/FindNetCDF.cmake @@ -0,0 +1,343 @@ +# (C) Copyright 2017-2020 UCAR +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# +# (C) Copyright 2011- ECMWF. +# +# This software is licensed under the terms of the Apache Licence Version 2.0 +# which can be obtained at http://www.apache.org/licenses/LICENSE-2.0. +# In applying this licence, ECMWF does not waive the privileges and immunities +# granted to it by virtue of its status as an intergovernmental organisation nor +# does it submit to any jurisdiction. +# +# Try to find NetCDF includes and library. +# Supports static and shared libaries and allows each component to be found in sepearte prefixes. +# +# This module defines +# +# - NetCDF_FOUND - System has NetCDF +# - NetCDF_INCLUDE_DIRS - the NetCDF include directories +# - NetCDF_VERSION - the version of NetCDF +# - NetCDF_CONFIG_EXECUTABLE - the netcdf-config executable if found +# - NetCDF_PARALLEL - Boolean True if NetCDF4 has parallel IO support via hdf5 and/or pnetcdf +# - NetCDF_HAS_PNETCDF - Boolean True if NetCDF4 has pnetcdf support +# +# Deprecated Defines +# - NetCDF_LIBRARIES - [Deprecated] Use NetCDF::NetCDF_ targets instead. +# +# +# Following components are available: +# +# - C - C interface to NetCDF (netcdf) +# - CXX - CXX4 interface to NetCDF (netcdf_c++4) +# - Fortran - Fortran interface to NetCDF (netcdff) +# +# For each component the following are defined: +# +# - NetCDF__FOUND - whether the component is found +# - NetCDF__LIBRARIES - the libraries for the component +# - NetCDF__LIBRARY_SHARED - Boolean is true if libraries for component are shared +# - NetCDF__INCLUDE_DIRS - the include directories for specified component +# - NetCDF::NetCDF_ - target of component to be used with target_link_libraries() +# +# The following paths will be searched in order if set in CMake (first priority) or environment (second priority) +# +# - NetCDF_ROOT - root of NetCDF installation +# - NetCDF_PATH - root of NetCDF installation +# +# The search process begins with locating NetCDF Include headers. If these are in a non-standard location, +# set one of the following CMake or environment variables to point to the location: +# +# - NetCDF_INCLUDE_DIR or NetCDF_${comp}_INCLUDE_DIR +# - NetCDF_INCLUDE_DIRS or NetCDF_${comp}_INCLUDE_DIR +# +# Notes: +# +# - Use "NetCDF::NetCDF_" targets only. NetCDF_LIBRARIES exists for backwards compatibility and should not be used. +# - These targets have all the knowledge of include directories and library search directories, and a single +# call to target_link_libraries will provide all these transitive properties to your target. Normally all that is +# needed to build and link against NetCDF is, e.g.: +# target_link_libraries(my_c_tgt PUBLIC NetCDF::NetCDF_C) +# - "NetCDF" is always the preferred naming for this package, its targets, variables, and environment variables +# - For compatibility, some variables are also set/checked using alternate names NetCDF4, NETCDF, or NETCDF4 +# - Environments relying on these older environment variable names should move to using a "NetCDF_ROOT" environment variable +# - Preferred component capitalization follows the CMake LANGUAGES variables: i.e., C, Fortran, CXX +# - For compatibility, alternate capitalizations are supported but should not be used. +# - If no components are defined, all components will be searched +# + +list( APPEND _possible_components C CXX Fortran ) + +## Include names for each component +set( NetCDF_C_INCLUDE_NAME netcdf.h ) +set( NetCDF_CXX_INCLUDE_NAME netcdf ) +set( NetCDF_Fortran_INCLUDE_NAME netcdf.mod ) + +## Library names for each component +set( NetCDF_C_LIBRARY_NAME netcdf ) +set( NetCDF_CXX_LIBRARY_NAME netcdf_c++4 ) +set( NetCDF_Fortran_LIBRARY_NAME netcdff ) + +## Enumerate search components +foreach( _comp ${_possible_components} ) + string( TOUPPER "${_comp}" _COMP ) + set( _arg_${_COMP} ${_comp} ) + set( _name_${_COMP} ${_comp} ) +endforeach() + +set( _search_components C) +foreach( _comp ${${CMAKE_FIND_PACKAGE_NAME}_FIND_COMPONENTS} ) + string( TOUPPER "${_comp}" _COMP ) + set( _arg_${_COMP} ${_comp} ) + list( APPEND _search_components ${_name_${_COMP}} ) + if( NOT _name_${_COMP} ) + message(SEND_ERROR "Find${CMAKE_FIND_PACKAGE_NAME}: COMPONENT ${_comp} is not a valid component. Valid components: ${_possible_components}" ) + endif() +endforeach() +list( REMOVE_DUPLICATES _search_components ) + +## Search hints for finding include directories and libraries +foreach( _comp IN ITEMS "_" "_C_" "_Fortran_" "_CXX_" ) + foreach( _name IN ITEMS NetCDF4 NetCDF NETCDF4 NETCDF ) + foreach( _var IN ITEMS ROOT PATH ) + list(APPEND _search_hints ${${_name}${_comp}${_var}} $ENV{${_name}${_comp}${_var}} ) + list(APPEND _include_search_hints + ${${_name}${_comp}INCLUDE_DIR} $ENV{${_name}${_comp}INCLUDE_DIR} + ${${_name}${_comp}INCLUDE_DIRS} $ENV{${_name}${_comp}INCLUDE_DIRS} ) + endforeach() + endforeach() +endforeach() +#Old-school HPC module env variable names +foreach( _name IN ITEMS NetCDF4 NetCDF NETCDF4 NETCDF ) + foreach( _comp IN ITEMS "_C" "_Fortran" "_CXX" ) + list(APPEND _search_hints ${${_name}} $ENV{${_name}}) + list(APPEND _search_hints ${${_name}${_comp}} $ENV{${_name}${_comp}}) + endforeach() +endforeach() + +## Find headers for each component +set(NetCDF_INCLUDE_DIRS) +set(_new_search_components) +foreach( _comp IN LISTS _search_components ) + if(NOT ${PROJECT_NAME}_NetCDF_${_comp}_FOUND) + list(APPEND _new_search_components ${_comp}) + endif() + find_file(NetCDF_${_comp}_INCLUDE_FILE + NAMES ${NetCDF_${_comp}_INCLUDE_NAME} + DOC "NetCDF ${_comp} include directory" + HINTS ${_include_search_hints} ${_search_hints} + PATH_SUFFIXES include include/netcdf + ) + mark_as_advanced(NetCDF_${_comp}_INCLUDE_FILE) + message(DEBUG "NetCDF_${_comp}_INCLUDE_FILE: ${NetCDF_${_comp}_INCLUDE_FILE}") + if( NetCDF_${_comp}_INCLUDE_FILE ) + get_filename_component(NetCDF_${_comp}_INCLUDE_FILE ${NetCDF_${_comp}_INCLUDE_FILE} ABSOLUTE) + get_filename_component(NetCDF_${_comp}_INCLUDE_DIR ${NetCDF_${_comp}_INCLUDE_FILE} DIRECTORY) + list(APPEND NetCDF_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIR}) + endif() +endforeach() +if(NetCDF_INCLUDE_DIRS) + list(REMOVE_DUPLICATES NetCDF_INCLUDE_DIRS) +endif() +set(NetCDF_INCLUDE_DIRS "${NetCDF_INCLUDE_DIRS}" CACHE STRING "NetCDF Include directory paths" FORCE) + +## Find n*-config executables for search components +foreach( _comp IN LISTS _search_components ) + if( _comp MATCHES "^(C)$" ) + set(_conf "c") + elseif( _comp MATCHES "^(Fortran)$" ) + set(_conf "f") + elseif( _comp MATCHES "^(CXX)$" ) + set(_conf "cxx4") + endif() + find_program( NetCDF_${_comp}_CONFIG_EXECUTABLE + NAMES n${_conf}-config + HINTS ${NetCDF_INCLUDE_DIRS} ${_include_search_hints} ${_search_hints} + PATH_SUFFIXES bin Bin ../bin ../../bin + DOC "NetCDF n${_conf}-config helper" ) + message(DEBUG "NetCDF_${_comp}_CONFIG_EXECUTABLE: ${NetCDF_${_comp}_CONFIG_EXECUTABLE}") +endforeach() + +set(_C_libs_flag --libs) +set(_Fortran_libs_flag --flibs) +set(_CXX_libs_flag --libs) +set(_C_includes_flag --includedir) +set(_Fortran_includes_flag --includedir) +set(_CXX_includes_flag --includedir) +function(netcdf_config exec flag output_var) + set(${output_var} False PARENT_SCOPE) + if( exec ) + execute_process( COMMAND ${exec} ${flag} RESULT_VARIABLE _ret OUTPUT_VARIABLE _val) + if( _ret EQUAL 0 ) + string( STRIP ${_val} _val ) + set( ${output_var} ${_val} PARENT_SCOPE ) + endif() + endif() +endfunction() + +## Find libraries for each component +set( NetCDF_LIBRARIES ) +foreach( _comp IN LISTS _search_components ) + string( TOUPPER "${_comp}" _COMP ) + + find_library( NetCDF_${_comp}_LIBRARY + NAMES ${NetCDF_${_comp}_LIBRARY_NAME} + DOC "NetCDF ${_comp} library" + HINTS ${NetCDF_${_comp}_INCLUDE_DIRS} ${_search_hints} + PATH_SUFFIXES lib64 lib ../lib64 ../lib ../../lib64 ../../lib ) + mark_as_advanced( NetCDF_${_comp}_LIBRARY ) + get_filename_component(NetCDF_${_comp}_LIBRARY ${NetCDF_${_comp}_LIBRARY} ABSOLUTE) + set(NetCDF_${_comp}_LIBRARY ${NetCDF_${_comp}_LIBRARY} CACHE STRING "NetCDF ${_comp} library" FORCE) + message(DEBUG "NetCDF_${_comp}_LIBRARY: ${NetCDF_${_comp}_LIBRARY}") + + + if( NetCDF_${_comp}_LIBRARY ) + if( NetCDF_${_comp}_LIBRARY MATCHES ".a$" ) + set( NetCDF_${_comp}_LIBRARY_SHARED FALSE ) + set( _library_type STATIC) + else() + if( NOT ${NetCDF_${_comp}_LIBRARY} IN_LIST NetCDF_LIBRARIES ) + list( APPEND NetCDF_LIBRARIES ${NetCDF_${_comp}_LIBRARY} ) + message(DEBUG "Adding new netcdf library [${_comp}]: ${NetCDF_${_comp}_LIBRARY}") + endif() + set( NetCDF_${_comp}_LIBRARY_SHARED TRUE ) + set( _library_type SHARED) + endif() + endif() + + #Use nc-config to set per-component LIBRARIES variable if possible + netcdf_config( ${NetCDF_${_comp}_CONFIG_EXECUTABLE} ${_${_comp}_libs_flag} _val ) + if( _val ) + set( NetCDF_${_comp}_LIBRARIES ${_val} ) + if(NOT NetCDF_${_comp}_LIBRARY_SHARED AND NOT NetCDF_${_comp}_FOUND) #Static targets should use nc_config to get a proper link line with all necessary static targets. + list( APPEND NetCDF_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + endif() + else() + set( NetCDF_${_comp}_LIBRARIES ${NetCDF_${_comp}_LIBRARY} ) + if(NOT NetCDF_${_comp}_LIBRARY_SHARED) + message(SEND_ERROR "Unable to properly find NetCDF. Found static libraries at: ${NetCDF_${_comp}_LIBRARY} but could not run nc-config: ${NetCDF_CONFIG_EXECUTABLE}") + endif() + endif() + + #Use nc-config to set per-component INCLUDE_DIRS variable if possible + netcdf_config( ${NetCDF_${_comp}_CONFIG_EXECUTABLE} ${_${_comp}_includes_flag} _val ) + if( _val ) + string( REPLACE " " ";" _val ${_val} ) + set( NetCDF_${_comp}_INCLUDE_DIRS ${_val} ) + else() + set( NetCDF_${_comp}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIR} ) + endif() + + if( NetCDF_${_comp}_LIBRARIES AND NetCDF_${_comp}_INCLUDE_DIRS ) + set( ${CMAKE_FIND_PACKAGE_NAME}_${_arg_${_COMP}}_FOUND TRUE ) + if (NOT TARGET NetCDF::NetCDF_${_comp}) + add_library(NetCDF::NetCDF_${_comp} ${_library_type} IMPORTED) + set_target_properties(NetCDF::NetCDF_${_comp} PROPERTIES + IMPORTED_LOCATION ${NetCDF_${_comp}_LIBRARY} + INTERFACE_INCLUDE_DIRECTORIES "${NetCDF_${_comp}_INCLUDE_DIRS}" + INTERFACE_LINK_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + endif() + endif() +endforeach() +set(NetCDF_LIBRARIES "${NetCDF_LIBRARIES}" CACHE STRING "NetCDF library targets" FORCE) + +## Find version via netcdf-config if possible +if (NetCDF_INCLUDE_DIRS) + if( NetCDF_C_CONFIG_EXECUTABLE ) + netcdf_config( ${NetCDF_C_CONFIG_EXECUTABLE} --version _vers ) + if( _vers ) + string(REGEX REPLACE ".* ((([0-9]+)\\.)+([0-9]+)).*" "\\1" NetCDF_VERSION "${_vers}" ) + endif() + else() + foreach( _dir IN LISTS NetCDF_INCLUDE_DIRS) + if( EXISTS "${_dir}/netcdf_meta.h" ) + file(STRINGS "${_dir}/netcdf_meta.h" _netcdf_version_lines + REGEX "#define[ \t]+NC_VERSION_(MAJOR|MINOR|PATCH|NOTE)") + string(REGEX REPLACE ".*NC_VERSION_MAJOR *\([0-9]*\).*" "\\1" _netcdf_version_major "${_netcdf_version_lines}") + string(REGEX REPLACE ".*NC_VERSION_MINOR *\([0-9]*\).*" "\\1" _netcdf_version_minor "${_netcdf_version_lines}") + string(REGEX REPLACE ".*NC_VERSION_PATCH *\([0-9]*\).*" "\\1" _netcdf_version_patch "${_netcdf_version_lines}") + string(REGEX REPLACE ".*NC_VERSION_NOTE *\"\([^\"]*\)\".*" "\\1" _netcdf_version_note "${_netcdf_version_lines}") + set(NetCDF_VERSION "${_netcdf_version_major}.${_netcdf_version_minor}.${_netcdf_version_patch}${_netcdf_version_note}") + unset(_netcdf_version_major) + unset(_netcdf_version_minor) + unset(_netcdf_version_patch) + unset(_netcdf_version_note) + unset(_netcdf_version_lines) + endif() + endforeach() + endif() +endif () + +## Detect additional package properties +netcdf_config(${NetCDF_C_CONFIG_EXECUTABLE} --has-parallel4 _val) +if( NOT _val MATCHES "^(yes|no)$" ) + netcdf_config(${NetCDF_C_CONFIG_EXECUTABLE} --has-parallel _val) +endif() +if( _val MATCHES "^(yes)$" ) + set(NetCDF_PARALLEL TRUE CACHE STRING "NetCDF has parallel IO capability via pnetcdf or hdf5." FORCE) +else() + set(NetCDF_PARALLEL FALSE CACHE STRING "NetCDF has no parallel IO capability." FORCE) +endif() + +## Finalize find_package +include(FindPackageHandleStandardArgs) + +if(NOT NetCDF_FOUND OR _new_search_components) + find_package_handle_standard_args( ${CMAKE_FIND_PACKAGE_NAME} + REQUIRED_VARS NetCDF_INCLUDE_DIRS NetCDF_LIBRARIES + VERSION_VAR NetCDF_VERSION + HANDLE_COMPONENTS ) +endif() + +foreach( _comp IN LISTS _search_components ) + if( NetCDF_${_comp}_FOUND ) + #Record found components to avoid duplication in NetCDF_LIBRARIES for static libraries + set(NetCDF_${_comp}_FOUND ${NetCDF_${_comp}_FOUND} CACHE BOOL "NetCDF ${_comp} Found" FORCE) + #Set a per-package, per-component found variable to communicate between multiple calls to find_package() + set(${PROJECT_NAME}_NetCDF_${_comp}_FOUND True) + endif() +endforeach() + +if( ${CMAKE_FIND_PACKAGE_NAME}_FOUND AND NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY AND _new_search_components) + message( STATUS "Find${CMAKE_FIND_PACKAGE_NAME} [${CMAKE_CURRENT_LIST_DIR}/FindNetCDF.cmake]:" ) + message( STATUS " - NetCDF_VERSION [${NetCDF_VERSION}]") + message( STATUS " - NetCDF_PARALLEL [${NetCDF_PARALLEL}]") + foreach( _comp IN LISTS _new_search_components ) + string( TOUPPER "${_comp}" _COMP ) + message( STATUS " - NetCDF_${_comp}_CONFIG_EXECUTABLE [${NetCDF_${_comp}_CONFIG_EXECUTABLE}]") + if( ${CMAKE_FIND_PACKAGE_NAME}_${_arg_${_COMP}}_FOUND ) + get_filename_component(_root ${NetCDF_${_comp}_INCLUDE_DIR}/.. ABSOLUTE) + if( NetCDF_${_comp}_LIBRARY_SHARED ) + message( STATUS " - NetCDF::NetCDF_${_comp} [SHARED] [Root: ${_root}] Lib: ${NetCDF_${_comp}_LIBRARY} ") + else() + message( STATUS " - NetCDF::NetCDF_${_comp} [STATIC] [Root: ${_root}] Lib: ${NetCDF_${_comp}_LIBRARY} ") + endif() + endif() + endforeach() +endif() + +foreach( _prefix NetCDF NetCDF4 NETCDF NETCDF4 ${CMAKE_FIND_PACKAGE_NAME} ) + set( ${_prefix}_INCLUDE_DIRS ${NetCDF_INCLUDE_DIRS} ) + set( ${_prefix}_LIBRARIES ${NetCDF_LIBRARIES}) + set( ${_prefix}_VERSION ${NetCDF_VERSION} ) + set( ${_prefix}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_FOUND} ) + set( ${_prefix}_CONFIG_EXECUTABLE ${NetCDF_CONFIG_EXECUTABLE} ) + set( ${_prefix}_PARALLEL ${NetCDF_PARALLEL} ) + + foreach( _comp ${_search_components} ) + string( TOUPPER "${_comp}" _COMP ) + set( _arg_comp ${_arg_${_COMP}} ) + set( ${_prefix}_${_comp}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_${_arg_comp}_FOUND} ) + set( ${_prefix}_${_COMP}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_${_arg_comp}_FOUND} ) + set( ${_prefix}_${_arg_comp}_FOUND ${${CMAKE_FIND_PACKAGE_NAME}_${_arg_comp}_FOUND} ) + + set( ${_prefix}_${_comp}_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + set( ${_prefix}_${_COMP}_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + set( ${_prefix}_${_arg_comp}_LIBRARIES ${NetCDF_${_comp}_LIBRARIES} ) + + set( ${_prefix}_${_comp}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIRS} ) + set( ${_prefix}_${_COMP}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIRS} ) + set( ${_prefix}_${_arg_comp}_INCLUDE_DIRS ${NetCDF_${_comp}_INCLUDE_DIRS} ) + endforeach() +endforeach() diff --git a/cmake/Modules/FindPIO.cmake b/cmake/Modules/FindPIO.cmake new file mode 100644 index 0000000000..4988264c46 --- /dev/null +++ b/cmake/Modules/FindPIO.cmake @@ -0,0 +1,181 @@ +# FindPIO.cmake +# +# Copyright UCAR 2020 +# +# Find PIO: A high-level Parallel I/O Library for structured grid applications +# https://github.com/NCAR/ParallelIO +# +# Components available for query: +# C - Has C support +# Fortran - Has Fortran support +# STATIC - Has static targets for supported LANG +# SHARED - Has shared targets for supported LANG +# +# Variables provided: +# PIO_FOUND - True if PIO was found +# PIO_VERSION - Version of installed PIO +# +# Targets provided: +# PIO::PIO_Fortran_STATIC - Fortran interface target for static libraries +# PIO::PIO_Fortran_SHARED - Fortran interface target for shared libraries +# PIO::PIO_Fortran - Fortran interface target alias to shared libraries if available else static libraries +# PIO::PIO_C_STATIC - C interface target for static libraries +# PIO::PIO_C_SHARED - C interface target for shared libraries +# PIO::PIO_C - C interface target alias to shared libraries if available else static libraries +# +# To control finding of this package, set PIO_ROOT environment variable to the full path to the prefix +# under which PIO was installed (e.g., /usr/local) +# + +## Find libraries and paths, and determine found components +find_path(PIO_INCLUDE_DIR NAMES pio.h HINTS "${PIO_PREFIX}" PATH_SUFFIXES include include/pio) +if(PIO_INCLUDE_DIR) + string(REGEX REPLACE "/include(/.+)?" "" PIO_PREFIX ${PIO_INCLUDE_DIR}) + set(PIO_PREFIX ${PIO_PREFIX} CACHE STRING "") + find_path(PIO_MODULE_DIR NAMES pio.mod PATHS "${PIO_PREFIX}" + PATH_SUFFIXES include include/pio lib/pio/module module module/pio NO_DEFAULT_PATH) + if(APPLE) + set(_SHARED_LIB_EXT .dylib) + else() + set(_SHARED_LIB_EXT .so) + endif() + find_library(PIO_C_STATIC_LIB libpioc.a PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + find_library(PIO_C_SHARED_LIB libpioc${_SHARED_LIB_EXT} PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + find_library(PIO_Fortran_STATIC_LIB libpiof.a PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + find_library(PIO_Fortran_SHARED_LIB libpiof${_SHARED_LIB_EXT} PATHS "${PIO_PREFIX}" PATH_SUFFIXES lib lib64 NO_DEFAULT_PATH) + unset(_SHARED_LIB_EXT) + + #Check for Fortran components + if(PIO_MODULE_DIR) + if(PIO_Fortran_STATIC_LIB) + set(PIO_Fortran_STATIC_FOUND 1) + endif() + if(PIO_Fortran_SHARED_LIB) + set(PIO_Fortran_SHARED_FOUND 1) + endif() + if(PIO_Fortran_STATIC_FOUND OR PIO_Fortran_SHARED_FOUND) + set(PIO_Fortran_FOUND 1) + endif() + endif() + #Check for C components + if(PIO_C_STATIC_LIB) + set(PIO_C_STATIC_FOUND 1) + endif() + if(PIO_C_SHARED_LIB) + set(PIO_C_SHARED_FOUND 1) + endif() + if(PIO_C_STATIC_FOUND OR PIO_C_SHARED_FOUND) + set(PIO_C_FOUND 1) + endif() + if(PIO_C_SHARED_FOUND AND (NOT PIO_Fortran_FOUND OR PIO_Fortran_SHARED_FOUND)) + set(PIO_SHARED_FOUND 1) + endif() + if(PIO_C_STATIC_FOUND AND (NOT PIO_Fortran_FOUND OR PIO_Fortran_STATIC_FOUND)) + set(PIO_STATIC_FOUND 1) + endif() +endif() + +## Debugging output +message(DEBUG "[FindPIO] PIO_INCLUDE_DIR: ${PIO_INCLUDE_DIR}") +message(DEBUG "[FindPIO] PIO_PREFIX: ${PIO_PREFIX}") +message(DEBUG "[FindPIO] PIO_MODULE_DIR: ${PIO_MODULE_DIR}") +message(DEBUG "[FindPIO] PIO_Fortran_STATIC_LIB: ${PIO_Fortran_STATIC_LIB}") +message(DEBUG "[FindPIO] PIO_Fortran_SHARED_LIB: ${PIO_Fortran_SHARED_LIB}") +message(DEBUG "[FindPIO] PIO_C_STATIC_LIB: ${PIO_C_STATIC_LIB}") +message(DEBUG "[FindPIO] PIO_C_SHARED_LIB: ${PIO_C_SHARED_LIB}") +message(DEBUG "[FindPIO] PIO_Fortran_FOUND: ${PIO_Fortran_FOUND}") +message(DEBUG "[FindPIO] PIO_C_FOUND: ${PIO_C_FOUND}") +message(DEBUG "[FindPIO] PIO_SHARED_FOUND: ${PIO_SHARED_FOUND}") +message(DEBUG "[FindPIO] PIO_STATIC_FOUND: ${PIO_STATIC_FOUND}") + +## Check package has been found correctly +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + PIO + REQUIRED_VARS + PIO_PREFIX + PIO_INCLUDE_DIR + HANDLE_COMPONENTS +) +message(DEBUG "[FindPIO] PIO_FOUND: ${PIO_FOUND}") + +## Create targets +set(_new_components) + + +# PIO::PIO_Fortran_STATIC imported interface target +if(PIO_Fortran_FOUND AND PIO_STATIC_FOUND AND NOT TARGET PIO::PIO_Fortran_STATIC) + add_library(PIO::PIO_Fortran_STATIC INTERFACE IMPORTED) + set_target_properties(PIO::PIO_Fortran_STATIC PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_Fortran_STATIC_LIB} + IMPORTED_GLOBAL True ) + if(PIO_MODULE_DIR AND NOT PIO_MODULE_DIR STREQUAL PIO_INCLUDE_DIR ) + set_property(TARGET PIO::PIO_Fortran_STATIC APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PIO_MODULE_DIR}) + endif() + target_link_libraries(PIO::PIO_Fortran_STATIC INTERFACE NetCDF::NetCDF_C) + set(_new_components 1) +endif() + +# PIO::PIO_Fortran_SHARED imported interface target +if(PIO_Fortran_FOUND AND PIO_SHARED_FOUND AND NOT TARGET PIO::PIO_Fortran_SHARED) + add_library(PIO::PIO_Fortran_SHARED INTERFACE IMPORTED) + set_target_properties(PIO::PIO_Fortran_SHARED PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_Fortran_SHARED_LIB} + IMPORTED_GLOBAL True ) + if(PIO_MODULE_DIR AND NOT PIO_MODULE_DIR STREQUAL PIO_INCLUDE_DIR ) + set_property(TARGET PIO::PIO_Fortran_SHARED APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PIO_MODULE_DIR}) + endif() + set(_new_components 1) +endif() + +# PIO::PIO_C_STATIC imported interface target +if(PIO_C_FOUND AND PIO_STATIC_FOUND AND NOT TARGET PIO::PIO_C_STATIC) + add_library(PIO::PIO_C_STATIC INTERFACE IMPORTED) + set_target_properties(PIO::PIO_C_STATIC PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_C_STATIC_LIB} + IMPORTED_GLOBAL True ) + target_link_libraries(PIO::PIO_C_STATIC INTERFACE NetCDF::NetCDF_C) + set(_new_components 1) +endif() + +# PIO::PIO_C_SHARED imported interface target +if(PIO_C_FOUND AND PIO_SHARED_FOUND AND NOT TARGET PIO::PIO_C_SHARED) + add_library(PIO::PIO_C_SHARED INTERFACE IMPORTED) + set_target_properties(PIO::PIO_C_SHARED PROPERTIES + INTERFACE_INCLUDE_DIRECTORIES ${PIO_INCLUDE_DIR} + INTERFACE_LINK_LIBRARIES ${PIO_C_SHARED_LIB} + IMPORTED_GLOBAL True ) + set(_new_components 1) +endif() + +# PIO::PIO_Fortran - Shared libraries if available, static otherwise +if(TARGET PIO::PIO_Fortran_SHARED) + add_library(PIO::PIO_Fortran ALIAS PIO::PIO_Fortran_SHARED) +elseif(TARGET PIO::PIO_Fortran_STATIC) + add_library(PIO::PIO_Fortran ALIAS PIO::PIO_Fortran_STATIC) +endif() + +# PIO::PIO_C - Shared libraries if available, static otherwise +if(TARGET PIO::PIO_C_SHARED) + add_library(PIO::PIO_C ALIAS PIO::PIO_C_SHARED) +elseif(TARGET PIO::PIO_C_STATIC) + add_library(PIO::PIO_C ALIAS PIO::PIO_C_STATIC) +endif() + +## Print status +if(${CMAKE_FIND_PACKAGE_NAME}_FOUND AND NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY AND _new_components) + message( STATUS "Find${CMAKE_FIND_PACKAGE_NAME}:" ) + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME}_PREFIX [${${CMAKE_FIND_PACKAGE_NAME}_PREFIX}]") + set(_found_comps) + foreach( _comp IN ITEMS Fortran C STATIC SHARED ) + if( ${CMAKE_FIND_PACKAGE_NAME}_${_comp}_FOUND ) + list(APPEND _found_comps ${_comp}) + endif() + endforeach() + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME} Components Found: ${_found_comps}") + unset(_found_comps) +endif() +unset(_new_components) diff --git a/cmake/Modules/FindPnetCDF.cmake b/cmake/Modules/FindPnetCDF.cmake new file mode 100644 index 0000000000..91a076ba57 --- /dev/null +++ b/cmake/Modules/FindPnetCDF.cmake @@ -0,0 +1,174 @@ +# FindPnetCDF.cmake +# +# Copyright UCAR 2020 +# +# Find PnetCDF: A Parallel I/O Library for NetCDF File Access +# https://parallel-netcdf.github.io/ +# +# Components available for query: +# C - Has C support +# CXX - Has CXX support +# Fortran - Has Fortran support +# NetCDF4 - Has NetCDF4 output support +# GPTL - Has profiling support with GPTL enabled +# Threads - Has thread safety enabled +# +# Variables provided: +# PnetCDF_FOUND - True if PnetCDFL was found +# PnetCDF_CONFIG_EXE - pnetcdf-config executable if found +# PnetCDF_VERSION - Version of installed PnetCDF +# PnetCDF_BIN_DIR - PnetCDF binary directory +# PnetCDF_DEBUG - True if PnetCDF is built in debug mode +# +# Targets provided: +# PnetCDF::PnetCDF_Fortran - Fortran interface target +# PnetCDF::PnetCDF_C - C interface target +# PnetCDF::PnetCDF_CXX - CXX interface target +# +# Functions provided: +# pnetcdf_get_config(ret_var flags) - Call `pnetcdf-config` with flags and set ret_var with output on execution success. +# +# +# This module requires the `pnetcdf-config` executable to detect the directories and compiler and linker flags +# necessary for the PnetCDF::PnetCDF target. To control where PnetCDF is found: +# * Option 1: Set an environment or cmake variable `PnetCDF_ROOT` to the install prefix for PnetCDF (e.g. /usr/local) +# * Option 2: Set an environment or cmake variable `PnetCDF_CONFIG_EXE` to the full path to the `pnetcdf-config` +# (e.g., /usr/local/bin/pnetcdf-config) +# + +find_program(PnetCDF_CONFIG_EXE NAMES pnetcdf-config PATH_SUFFIXES bin bin64 PATHS + $ENV{PnetCDF_CONFIG_EXE} ${PnetCDF_ROOT} $ENV{PnetCDF_ROOT} ${PNETCDF_ROOT} $ENV{PNETCDF_ROOT}) +message(DEBUG "[FindPnetCDF] Using PnetCDF_CONFIG_EXE:${PnetCDF_CONFIG_EXE}") + +# pnetcdf_get_config(ret_var flags...) +# Get the output of pnetcdf-config +# Args: +# ret_var: return variable name +# flags: flags to pass to pnetcdf-config +function(pnetcdf_get_config ret_var pcflags) + execute_process(COMMAND ${PnetCDF_CONFIG_EXE} ${pcflags} OUTPUT_VARIABLE _out RESULT_VARIABLE _ret OUTPUT_STRIP_TRAILING_WHITESPACE) + if(_ret EQUAL 0) + separate_arguments(_out) + set(${ret_var} ${_out} PARENT_SCOPE) + else() + set(${ret_var} "" PARENT_SCOPE) + endif() +endfunction() + +## Find libraries and paths, and determine found components +if(EXISTS ${PnetCDF_CONFIG_EXE}) + #Use pnetcdf-config to find the prefix, flags, directories, executables, and libraries + pnetcdf_get_config(PnetCDF_VERSION --version) + string(REGEX MATCH "([0-9.]+)" PnetCDF_VERSION "${PnetCDF_VERSION}") #Match only version actual number + + pnetcdf_get_config(PnetCDF_PREFIX --prefix) + pnetcdf_get_config(PnetCDF_CXX_FOUND --has-c++) + pnetcdf_get_config(PnetCDF_Fortran_FOUND --has-fortran) + pnetcdf_get_config(PnetCDF_NetCDF4_FOUND --netcdf4) + pnetcdf_get_config(PnetCDF_GPTL_FOUND --profiling) + pnetcdf_get_config(PnetCDF_Threads_FOUND --thread-safe) + pnetcdf_get_config(PnetCDF_DEBUG --debug) + pnetcdf_get_config(PnetCDF_INCLUDE_DIR --includedir) + pnetcdf_get_config(PnetCDF_LIB_DIR --libdir) + + #Translate boolean variables from pnetcdf-config enabled/disabled to True/False + foreach(_var IN ITEMS PnetCDF_CXX_FOUND PnetCDF_Fortran_FOUND PnetCDF_NetCDF4_FOUND PnetCDF_GPTL_FOUND PnetCDF_Threads_FOUND PnetCDF_DEBUG) + if( ${_var} MATCHES "(enabled)|([Yy][Ee][Ss])") + set(${_var} True) + else() + set(${_var} False) + endif() + endforeach() + + find_path(PnetCDF_MODULE_DIR NAMES pnetcdf.mod HINTS ${PnetCDF_PREFIX} ${PnetCDF_INCLUDE_DIR} + PATH_SUFFIXES include include/pnetcdf module module/pnetcdf lib/pnetcdf/module NO_DEFAULT_PATH) + if(PnetCDF_Fortran_FOUND AND NOT EXISTS ${PnetCDF_MODULE_DIR}) + message(WARNING "[PnetCDF] pnetcdf-config --has-fortran=yes, but could not find pnetcdf.mod. Set PnetCDF_MODULE_DIR to path containing pnetcdf.mod") + set(PnetCDF_Fortran_FOUND NO) + endif() + + if(PnetCDF_INCLUDE_DIR AND PnetCDF_LIB_DIR) + set(PnetCDF_C_FOUND True) + endif() + + find_path(PnetCDF_BIN_DIR NAMES pnetcdf-config PATH_SUFFIXES bin PATHS ${PnetCDF_PREFIX} NO_DEFAULT_PATH) + find_library(PnetCDF_LIBRARY NAMES pnetcdf PATH_SUFFIXES lib lib64 PATHS ${PnetCDF_PREFIX} NO_DEFAULT_PATH) + #Hide non-documented cache variables reserved for internal/advanced usage + mark_as_advanced( PnetCDF_MODULE_DIR PnetCDF_LIBRARY ) +endif() + +## Debugging output +message(DEBUG "[FindPnetCDF] PnetCDF_CONFIG_EXE: ${PnetCDF_CONFIG_EXE}") +message(DEBUG "[FindPnetCDF] PnetCDF_VERSION: ${PnetCDF_VERSION}") +message(DEBUG "[FindPnetCDF] PnetCDF_C_FOUND: ${PnetCDF_C_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_CXX_FOUND: ${PnetCDF_CXX_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_Fortran_FOUND: ${PnetCDF_Fortran_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_NetCDF4_FOUND: ${PnetCDF_NetCDF4_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_GPTL_FOUND: ${PnetCDF_GPTL_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_Threads_FOUND: ${PnetCDF_Threads_FOUND}") +message(DEBUG "[FindPnetCDF] PnetCDF_DEBUG: ${PnetCDF_DEBUG}") +message(DEBUG "[FindPnetCDF] PnetCDF_PREFIX: ${PnetCDF_PREFIX}") +message(DEBUG "[FindPnetCDF] PnetCDF_BIN_DIR: ${PnetCDF_BIN_DIR}") +message(DEBUG "[FindPnetCDF] PnetCDF_INCLUDE_DIR: ${PnetCDF_INCLUDE_DIR}") +message(DEBUG "[FindPnetCDF] PnetCDF_MODULE_DIR: ${PnetCDF_MODULE_DIR}") +message(DEBUG "[FindPnetCDF] PnetCDF_LIB_DIR: ${PnetCDF_LIB_DIR}") + +## Check package has been found correctly +include(FindPackageHandleStandardArgs) +find_package_handle_standard_args( + PnetCDF + REQUIRED_VARS + PnetCDF_CONFIG_EXE + PnetCDF_PREFIX + VERSION_VAR + PnetCDF_VERSION + HANDLE_COMPONENTS +) +message(DEBUG "[FindPnetCDF] PnetCDF_FOUND: ${PnetCDF_FOUND}") + +## Create targets +set(_new_components) + +# PnetCDF::PnetCDF_Fortran imported interface target +if(PnetCDF_Fortran_FOUND AND NOT TARGET PnetCDF::PnetCDF_Fortran) + add_library(PnetCDF::PnetCDF_Fortran INTERFACE IMPORTED) + set_target_properties(PnetCDF::PnetCDF_Fortran PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + if(PnetCDF_MODULE_DIR AND NOT PnetCDF_MODULE_DIR STREQUAL PnetCDF_INCLUDE_DIR ) + set_property(TARGET PnetCDF::PnetCDF_Fortran APPEND PROPERTY INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_MODULE_DIR}) + endif() + set(_new_components 1) + target_link_libraries(PnetCDF::PnetCDF_Fortran INTERFACE -lpnetcdf) +endif() + +# PnetCDF::PnetCDF_C imported interface target +if(PnetCDF_C_FOUND AND NOT TARGET PnetCDF::PnetCDF_C) + add_library(PnetCDF::PnetCDF_C INTERFACE IMPORTED) + set_target_properties(PnetCDF::PnetCDF_C PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + set(_new_components 1) +endif() + +# PnetCDF::PnetCDF_CXX imported interface target +if(PnetCDF_CXX_FOUND AND NOT TARGET PnetCDF::PnetCDF_CXX) + add_library(PnetCDF::PnetCDF_CXX INTERFACE IMPORTED) + set_target_properties(PnetCDF::PnetCDF_CXX PROPERTIES INTERFACE_INCLUDE_DIRECTORIES ${PnetCDF_INCLUDE_DIR} + INTERFACE_LINK_DIRECTORIES ${PnetCDF_LIB_DIR}) + set(_new_components 1) +endif() + +## Print status +if(${CMAKE_FIND_PACKAGE_NAME}_FOUND AND NOT ${CMAKE_FIND_PACKAGE_NAME}_FIND_QUIETLY AND _new_components) + message( STATUS "Find${CMAKE_FIND_PACKAGE_NAME}:" ) + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME}_VERSION [${${CMAKE_FIND_PACKAGE_NAME}_VERSION}]") + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME}_PREFIX [${${CMAKE_FIND_PACKAGE_NAME}_PREFIX}]") + set(_found_comps) + foreach( _comp IN ITEMS Fortran C CXX NetCDF4 GPTL Threads ) + if( ${CMAKE_FIND_PACKAGE_NAME}_${_comp}_FOUND ) + list(APPEND _found_comps ${_comp}) + endif() + endforeach() + message( STATUS " - ${CMAKE_FIND_PACKAGE_NAME} Components Found: ${_found_comps}") + unset(_found_comps) +endif() +unset(_new_components) diff --git a/cmake/PackageConfig.cmake.in b/cmake/PackageConfig.cmake.in new file mode 100644 index 0000000000..e7b8860c9c --- /dev/null +++ b/cmake/PackageConfig.cmake.in @@ -0,0 +1,121 @@ +@PACKAGE_INIT@ + +# @PROJECT_NAME@-config.cmake +# +# Valid Find COMPONENTS: +# * SHARED - Require shared libraries. +# * STATIC - Require static libraries. +# * DOUBLE_PRECISION - Find double precision libraries +# * PROFILE - True if GPTL profiling is enabled +# * OpenMP - True if OpenMP support is enabled +# * core_atmosphere - Find atmosphere core +# * core_init_atmosphere - Find init_atmosphere core +# * core_ocean - Find ocean core +# * core_landice - Find landice core +# * core_seaice - Find seaice core +# * core_sw - Find sw core +# * core_test - Find test core +# +# +# Output variables set: +# * @PROJECT_NAME@_VERSION - Version of install package +# * @PROJECT_NAME@_VERSION_MAJOR - Major version of install package +# * @PROJECT_NAME@_VERSION_MINOR - Minor version of install package +# * @PROJECT_NAME@_MODULES_Fortran_COMPILER_ID - Compiler used to generate Fortran Modules +# * @PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION - Compiler version used to generate Fortran Modules +# * @PROJECT_NAME@_CORE__DATADIR - Location for data files for core (namelist, streams, data tables, etc.) +# * @PROJECT_NAME@_BINDIR - Location for installed auxiliary binaries. +# + +# Imported interface targets provided: +# * @PROJECT_NAME@::core:: - Core targets +# * @PROJECT_NAME@::operators - Operators library target +# * @PROJECT_NAME@::framework - Framework library target +# * @PROJECT_NAME@::external::esmf - exmf_time library target +# * @PROJECT_NAME@::external::ezxml - ezxml library target +# + +# * @PROJECT_NAME@::@PROJECT_NAME@_shared - shared library target: + +#Include targets file. This will create IMPORTED target @PROJECT_NAME@ +string(TOLOWER @PROJECT_NAME@ _project_name_lower) +if(NOT TARGET @PROJECT_NAME@::framework) + include("${CMAKE_CURRENT_LIST_DIR}/${_project_name_lower}-targets-external.cmake") + include("${CMAKE_CURRENT_LIST_DIR}/${_project_name_lower}-targets.cmake") + include("${CMAKE_CURRENT_LIST_DIR}/${_project_name_lower}-targets-core.cmake") +endif() + +set(@PROJECT_NAME@_VERSION @PROJECT_VERSION@) +set(@PROJECT_NAME@_VERSION_MAJOR @PROJECT_VERSION_MAJOR@) +set(@PROJECT_NAME@_VERSION_MINOR @PROJECT_VERSION_MINOR@) + +#Export Fortran compiler version and check module compatibility +set(@PROJECT_NAME@_MODULES_Fortran_COMPILER_ID @CMAKE_Fortran_COMPILER_ID@) +set(@PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION @CMAKE_Fortran_COMPILER_VERSION@) +if(NOT @PROJECT_NAME@_MODULES_Fortran_COMPILER_ID STREQUAL CMAKE_Fortran_COMPILER_ID + OR NOT @PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION VERSION_EQUAL CMAKE_Fortran_COMPILER_VERSION) + message(SEND_ERROR "Package @PROJECT_NAME@ provides Fortran modules built with " + "${@PROJECT_NAME@_MODULES_Fortran_COMPILER_ID}-${@PROJECT_NAME@_MODULES_Fortran_COMPILER_VERSION} " + "but this build for ${PROJECT_NAME} uses incompatible compiler ${CMAKE_Fortran_COMPILER_ID}-${CMAKE_Fortran_COMPILER_VERSION}") +endif() + +set_and_check(@PROJECT_NAME@_BINDIR @PACKAGE_BINDIR@) +set_and_check(@PROJECT_NAME@_CMAKE_MODULE_PATH @PACKAGE_CMAKE_MODULE_INSTALL_PATH@) +set(CMAKE_MODULE_PATH ${@PROJECT_NAME@_CMAKE_MODULE_PATH} ${CMAKE_MODULE_PATH}) + +include(CMakeFindDependencyMacro) +if(@OpenMP_Fortran_FOUND@) #OpenMP_Fortran_FOUND + if(NOT OpenMP_Fortran_FOUND) + find_package(OpenMP REQUIRED COMPONENTS Fortran) + endif() + set(@PROJECT_NAME@_OpenMP_FOUND True) +endif() +if(NOT MPI_Fortran_FOUND) + find_package(MPI REQUIRED COMPONENTS Fortran) +endif() +if(NOT NetCDF_Fortran_FOUND) + find_package(NetCDF REQUIRED COMPONENTS Fortran) +endif() +find_package(PnetCDF REQUIRED COMPONENTS Fortran) +find_package(PIO REQUIRED COMPONENTS Fortran C) +if(@MPAS_PROFILE@) #MPAS_PROFILE + if(NOT GPTL_FOUND) + find_dependency(GPTL REQUIRED) + endif() + set(@PROJECT_NAME@_PROFILE_FOUND) +endif() + +if(@BUILD_SHARED_LIBS@) #BUILD_SHARED_LIBS + set(@PROJECT_NAME@_SHARED_FOUND True) +else() + set(@PROJECT_NAME@_STATIC_FOUND True) +endif() +if(@MPAS_DOUBLE_PRECISION@) #MPAS_DOUBLE_PRECISION + set(@PROJECT_NAME@_DOUBLE_PRECISION_FOUND True) +else() + set(@PROJECT_NAME@_DOUBLE_PRECISION_FOUND False) +endif() +set(MPAS_CORES @MPAS_CORES@) +foreach(_core IN LISTS MPAS_CORES) + string(TOUPPER ${_core} _CORE) + set_and_check(@PROJECT_NAME@_CORE_${_CORE}_DATADIR @PACKAGE_CORE_DATADIR_ROOT@/core_${_core}) + set(@PROJECT_NAME@_core_${_core}_FOUND True) +endforeach() + +check_required_components("@PROJECT_NAME@") + +## Print status +if(NOT @PROJECT_NAME@_FIND_QUIETLY) + #Get list of all found components for printing + set(_found_components) + set(_all_components SHARED STATIC PROFILE OpenMP DOUBLE_PRECISION core_atmosphere core_init_atmosphere core_landice core_ocean core_sw core_test) + foreach(_cmp IN LISTS _all_components) + if(@PROJECT_NAME@_${_cmp}_FOUND) + list(APPEND _found_components ${_cmp}) + endif() + endforeach() + + message(STATUS "Found @PROJECT_NAME@: (version: \"@PROJECT_VERSION@\") (components: ${_found_components})") + unset(_found_components) + unset(_all_components) +endif() diff --git a/docs/Makefile b/docs/Makefile new file mode 100644 index 0000000000..19e1d4f711 --- /dev/null +++ b/docs/Makefile @@ -0,0 +1,20 @@ +# Minimal makefile for Sphinx documentation +# + +# You can set these variables from the command line. +SPHINXOPTS = +SPHINXBUILD = sphinx-build +SPHINXPROJ = mpas_model +SOURCEDIR = . +BUILDDIR = _build + +# Put it first so that "make" without argument is like "make help". +help: + @$(SPHINXBUILD) -M help "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) + +.PHONY: help Makefile + +# Catch-all target: route all unknown targets to Sphinx using the new +# "make mode" option. $(O) is meant as a shortcut for $(SPHINXOPTS). +%: Makefile + @$(SPHINXBUILD) -M $@ "$(SOURCEDIR)" "$(BUILDDIR)" $(SPHINXOPTS) $(O) diff --git a/docs/conf.py b/docs/conf.py new file mode 100644 index 0000000000..5d13fca7dd --- /dev/null +++ b/docs/conf.py @@ -0,0 +1,182 @@ +# -*- coding: utf-8 -*- +# +# MPAS-Model documentation build configuration file, created by +# sphinx-quickstart on Sat Mar 25 14:39:11 2017. +# +# This file is execfile()d with the current directory set to its +# containing dir. +# +# Note that not all possible configuration values are present in this +# autogenerated file. +# +# All configuration values have a default; values that are commented out +# serve to show the default. + +import os + +# -- General configuration ------------------------------------------------ + +# If your documentation needs a minimal Sphinx version, state it here. +# +# needs_sphinx = '1.0' + +# Add any Sphinx extension module names here, as strings. They can be +# extensions coming with Sphinx (named 'sphinx.ext.*') or your custom +# ones. +extensions = ['sphinx.ext.autodoc', + 'sphinx.ext.autosummary', + 'sphinx.ext.intersphinx', + 'sphinx.ext.mathjax', + 'sphinx.ext.viewcode', + 'sphinx.ext.napoleon'] + +autosummary_generate = True + +# Otherwise, the Return parameter list looks different from the Parameters list +napoleon_use_rtype = False +# Otherwise, the Attributes parameter list looks different from the Parameters +# list +napoleon_use_ivar = True + +# Add any paths that contain templates here, relative to this directory. +templates_path = ['_templates'] + +# The suffix(es) of source filenames. +# You can specify multiple suffix as a list of string: +# +source_suffix = ['.rst'] +# source_suffix = '.rst' + +# The master toctree document. +master_doc = 'index' + +# General information about the project. +project = u'MPAS-Model' +copyright = u'Copyright (c) 2013-2020, Los Alamos National Security, LLC (LANS) (Ocean: LA-CC-13-047;' \ + u'Land Ice: LA-CC-13-117) and the University Corporation for Atmospheric Research (UCAR).' +author = u'Xylar Asay-Davis, Doug Jacobsen, Michael Duda, Mark Petersen, ' \ + u'Matt Hoffman, Adridan Turner, Philip Wolfram' + +# The version info for the project you're documenting, acts as replacement for +# |version| and |release|, also used in various other places throughout the +# built documents. +if 'DOCS_VERSION' in os.environ: + version = os.environ.get('DOCS_VERSION') + release = version +else: + # The short X.Y.Z version. + version = '7.0' + # The full version, including alpha/beta/rc tags. + release = '7.0' + +# The language for content autogenerated by Sphinx. Refer to documentation +# for a list of supported languages. +# +# This is also used if you do content translation via gettext catalogs. +# Usually you set "language" from the command line for these cases. +language = None + +# List of patterns, relative to source directory, that match files and +# directories to ignore when looking for source files. +# This patterns also effect to html_static_path and html_extra_path +exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store', + 'design_docs/template.md'] + +# The name of the Pygments (syntax highlighting) style to use. +pygments_style = 'sphinx' + +# If true, `todo` and `todoList` produce output, else they produce nothing. +todo_include_todos = False + + +# -- Options for HTML output ---------------------------------------------- + +# The theme to use for HTML and HTML Help pages. See the documentation for +# a list of builtin themes. +# + +# on_rtd is whether we are on readthedocs.org, this line of code grabbed from +# docs.readthedocs.org +on_rtd = os.environ.get('READTHEDOCS', None) == 'True' + +if not on_rtd: # only import and set the theme if we're building docs locally + import sphinx_rtd_theme + html_theme = 'sphinx_rtd_theme' + html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] + +# Theme options are theme-specific and customize the look and feel of a theme +# further. For a list of options available for each theme, see the +# documentation. +# +# html_theme_options = {} + +# Add any paths that contain custom static files (such as style sheets) here, +# relative to this directory. They are copied after the builtin static files, +# so a file named "default.css" will overwrite the builtin "default.css". +html_static_path = ['_static'] + + +# -- Options for HTMLHelp output ------------------------------------------ + +# Output file base name for HTML help builder. +htmlhelp_basename = 'mpas_model_doc' + + +# -- Options for LaTeX output --------------------------------------------- + +latex_elements = { + # The paper size ('letterpaper' or 'a4paper'). + # + # 'papersize': 'letterpaper', + + # The font size ('10pt', '11pt' or '12pt'). + # + # 'pointsize': '10pt', + + # Additional stuff for the LaTeX preamble. + # + # 'preamble': '', + + # Latex figure (float) alignment + # + # 'figure_align': 'htbp', +} + +# Grouping the document tree into LaTeX files. List of tuples +# (source start file, target name, title, +# author, documentclass [howto, manual, or own class]). +latex_documents = [ + (master_doc, 'mpas_model.tex', u'MPAS-Model Documentation', + author, 'manual'), +] + + +# -- Options for manual page output --------------------------------------- + +# One entry per manual page. List of tuples +# (source start file, name, description, authors, manual section). +man_pages = [ + (master_doc, 'mpas_model', u'MPAS-Model Documentation', + [author], 1) +] + + +# -- Options for Texinfo output ------------------------------------------- + +# Grouping the document tree into Texinfo files. List of tuples +# (source start file, target name, title, author, +# dir menu entry, description, category) +texinfo_documents = [ + (master_doc, 'mpas_model', u'MPAS-Model Documentation', + author, 'MPAS-Model', 'One line description of project.', + 'Miscellaneous'), +] + +# Example configuration for intersphinx: refer to the Python standard library. +intersphinx_mapping = { + 'python': ('https://docs.python.org/', None), + 'numpy': ('http://docs.scipy.org/doc/numpy/', None), + 'xarray': ('http://xarray.pydata.org/en/stable/', None)} + + +github_doc_root = 'https://github.com/rtfd/recommonmark/tree/master/doc/' diff --git a/docs/index.rst b/docs/index.rst new file mode 100644 index 0000000000..c7fd593a96 --- /dev/null +++ b/docs/index.rst @@ -0,0 +1,23 @@ +MPAS-Model +========== + +The Model for Prediction Across Scales (MPAS) is a collaborative project for +developing atmosphere, ocean, and other earth-system simulation components for +use in climate, regional climate, and weather studies. The primary development +partners are the climate modeling group at Los Alamos National Laboratory +(COSIM) and the National Center for Atmospheric Research. Both primary +partners are responsible for the MPAS framework, operators, and tools common to +the applications; LANL has primary responsibility for the ocean, sea-ice and +land-ice models, and NCAR has primary responsibility for the atmospheric model. + +The MPAS framework facilitates the rapid development and prototyping of models +by providing infrastructure typically required by model developers, including +high-level data types, communication routines, and I/O routines. By using MPAS, +developers can leverage pre-existing code and focus more on development of + +.. toctree:: + :titlesonly: + + ocean/index + + diff --git a/docs/ocean/design_docs/index.rst b/docs/ocean/design_docs/index.rst new file mode 100644 index 0000000000..3f845b901f --- /dev/null +++ b/docs/ocean/design_docs/index.rst @@ -0,0 +1,9 @@ +Design Docs +=========== + +Design document describing new capabilities added to MPAS-Ocean. + +.. toctree:: + :titlesonly: + + time-varying-wind diff --git a/docs/ocean/index.rst b/docs/ocean/index.rst new file mode 100644 index 0000000000..d5f9bf70ea --- /dev/null +++ b/docs/ocean/index.rst @@ -0,0 +1,7 @@ +MPAS-Ocean +========== + +.. toctree:: + :titlesonly: + + design_docs/index diff --git a/src/Makefile b/src/Makefile index cc0cc020d9..b9c037c8cc 100644 --- a/src/Makefile +++ b/src/Makefile @@ -6,12 +6,6 @@ include Makefile.in.$(ESM) else -ifeq "$(AUTOCLEAN)" "true" -AUTOCLEAN_DEPS=clean_shared -else -AUTOCLEAN_DEPS= -endif - all: mpas mpas: $(AUTOCLEAN_DEPS) externals frame ops dycore drver @@ -45,18 +39,24 @@ dycore: $(AUTOCLEAN_DEPS) build_tools externals frame ops clean: clean_shared clean_core clean_core: +ifeq "$(AUTOCLEAN)" "true" + $(info ) + $(info *********************************************************************************************) + $(info The $(CORE) core will be cleaned and re-compiled.) + $(info *********************************************************************************************) + $(info ) +endif if [ -d core_$(CORE) ] ; then \ ( cd core_$(CORE); $(MAKE) clean ) \ fi; clean_shared: ifeq "$(AUTOCLEAN)" "true" - @echo "" - @echo "*********************************************************************************************" - @echo "The MPAS infrastructure is currently built for a core different from $(CORE)." - @echo "The infrastructure will be cleaned and re-built for the $(CORE) core." - @echo "*********************************************************************************************" - @echo "" + $(info ) + $(info *********************************************************************************************) + $(info The infrastructure will be cleaned and re-compiled.) + $(info *********************************************************************************************) + $(info ) endif $(RM) libframework.a libops.a libdycore.a lib$(CORE).a *.o ( cd tools; $(MAKE) clean ) diff --git a/src/Makefile.in.CESM b/src/Makefile.in.CESM deleted file mode 100644 index 7644f65c4a..0000000000 --- a/src/Makefile.in.CESM +++ /dev/null @@ -1,90 +0,0 @@ -# Duplicate logic from Tools/Makefile to set compile_threaded -compile_threaded = false -ifeq ($(strip $(SMP)),TRUE) - compile_threaded = true - THREADDIR = threads -else - ifeq ($(strip $(BUILD_THREADED)),TRUE) - compile_threaded = true - THREADDIR = threads - else - THREADDIR = nothreads - endif -endif -# End duplicated logic - -include $(CASEROOT)/Macros.make - -ifneq ($(wildcard core_$(CORE)/build_options.mk), ) # Check for build_options.mk - include core_$(CORE)/build_options.mk -else # ELSE Use Default Options - EXE_NAME=$(CORE)_model - NAMELIST_SUFFIX=$(CORE) -endif - -# Map the ESM component corresponding to each MPAS core -ifeq "$(CORE)" "ocean" - COMPONENT=ocn -else ifeq "$(CORE)" "landice" - COMPONENT=glc -else ifeq "$(CORE)" "seaice" - COMPONENT=ice -endif - -ifeq ($(strip $(USE_ESMF_LIB)), TRUE) - ESMFDIR = esmf -else - ESMFDIR = noesmf -endif - -RM = rm -f -CPP = cpp -P -traditional -FC=$(MPIFC) -CC=$(MPICC) -CXX=$(MPICXX) -NETCDF=$(NETCDF_PATH) -PNETCDF=$(PNETCDF_PATH) -PIO=$(EXEROOT)/pio -FILE_OFFSET = -DOFFSET64BIT -override CFLAGS += -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS -override FFLAGS += -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS -override CPPFLAGS += $(CPPDEFS) $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE) -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -D_MPI -DMPAS_NAMELIST_SUFFIX=$(NAMELIST_SUFFIX) -DMPAS_EXE_NAME=$(EXE_NAME) -DMPAS_PERF_MOD_TIMERS -override CPPINCLUDES += -I$(EXEROOT)/$(COMPONENT)/source/inc -I$(SHAREDPATH)/include -I$(SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include -override FCINCLUDES += -I$(EXEROOT)/$(COMPONENT)/source/inc -I$(SHAREDPATH)/include -I$(SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include -LIBS += -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -L$(LIBROOT) -L$(SHAREDPATH)/lib -lpio -lpnetcdf -lnetcdf - -ifneq (,$(findstring FORTRANUNDERSCORE, $(CPPFLAGS))) -ifeq (,$(findstring DUNDERSCORE, $(CPPFLAGS))) - override CPPFLAGS += -DUNDERSCORE -endif -endif - -ifeq ($(DEBUG), TRUE) - override CPPFLAGS += -DMPAS_DEBUG -endif - -ifeq ($(compile_threaded), true) - override CPPFLAGS += -DMPAS_OPENMP -endif - -all: - @echo $(CPPINCLUDES) - @echo $(FCINCLUDES) - ( $(MAKE) mpas RM="$(RM)" CPP="$(CPP)" NETCDF="$(NETCDF)" PNETCDF="$(PNETCDF)" \ - PIO="$(PIO)" FC="$(FC)" CC="$(CC)" CXX="$(CXX)" SFC="$(SFC)" SCC="$(SCC)" \ - CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" FCINCLUDES="$(FCINCLUDES)" \ - FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" LDFLAGS="$(LDFLAGS)" ) - -mpas: externals frame ops dycore drver - ar ru lib$(COMPONENT).a framework/*.o - ar ru lib$(COMPONENT).a operators/*.o - ar ru lib$(COMPONENT).a external/ezxml/*.o - ar ru lib$(COMPONENT).a `find core_$(CORE)/ -type f -name "*.o"` # Find command finds objects in any subdirectories - ar ru lib$(COMPONENT).a $(DRIVER)/*.o - -externals: - ( cd external; $(MAKE) FC="$(FC)" SFC="$(SFC)" CC="$(CC)" CXX="$(CXX)" SCC="$(SCC)" FFLAGS="$(FFLAGS)" CFLAGS="$(CFLAGS)" CPP="$(CPP)" NETCDF="$(NETCDF)" CORE="$(CORE)" ezxml-lib ) - -drver: externals frame ops dycore - ( cd $(DRIVER); $(MAKE) CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)" FREEFLAGS="$(FREEFLAGS)" all ) - diff --git a/src/Makefile.in.ACME b/src/Makefile.in.E3SM similarity index 77% rename from src/Makefile.in.ACME rename to src/Makefile.in.E3SM index ad507cf3af..dabf51adac 100644 --- a/src/Makefile.in.ACME +++ b/src/Makefile.in.E3SM @@ -1,11 +1,11 @@ # Duplicate logic from Tools/Makefile to set compile_threaded -compile_threaded = false +compile_threaded = FALSE ifeq ($(strip $(SMP)),TRUE) - compile_threaded = true + compile_threaded = TRUE THREADDIR = threads else ifeq ($(strip $(BUILD_THREADED)),TRUE) - compile_threaded = true + compile_threaded = TRUE THREADDIR = threads else THREADDIR = nothreads @@ -14,6 +14,10 @@ endif # End duplicated logic include $(CASEROOT)/Macros.make +# Load machine/compiler specific settings +-include $(CASEROOT)/Depends.$(COMPILER) +-include $(CASEROOT)/Depends.$(MACH) +-include $(CASEROOT)/Depends.$(MACH).$(COMPILER) ifneq ($(wildcard core_$(CORE)/build_options.mk), ) # Check for build_options.mk include core_$(CORE)/build_options.mk @@ -46,27 +50,25 @@ NETCDF=$(NETCDF_PATH) PNETCDF=$(PNETCDF_PATH) PIO=$(INSTALL_SHAREDPATH)/pio FILE_OFFSET = -DOFFSET64BIT -override CFLAGS += -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS -override FFLAGS += -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS -override CPPFLAGS += $(CPPDEFS) $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE) -DMPAS_NO_LOG_REDIRECT -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -D_MPI -DMPAS_NAMELIST_SUFFIX=$(NAMELIST_SUFFIX) -DMPAS_EXE_NAME=$(EXE_NAME) -DMPAS_PERF_MOD_TIMERS +override CFLAGS += -DMPAS_NO_LOG_REDIRECT -DUSE_PIO2 -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS +override FFLAGS += -DMPAS_NO_LOG_REDIRECT -DUSE_PIO2 -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -DMPAS_PERF_MOD_TIMERS +override CPPFLAGS += $(CPPDEFS) $(MODEL_FORMULATION) $(FILE_OFFSET) $(ZOLTAN_DEFINE) -DMPAS_NO_LOG_REDIRECT -DUSE_PIO2 -DMPAS_NO_ESMF_INIT -DMPAS_ESM_SHR_CONST -D_MPI -DMPAS_NAMELIST_SUFFIX=$(NAMELIST_SUFFIX) -DMPAS_EXE_NAME=$(EXE_NAME) -DMPAS_PERF_MOD_TIMERS override CPPINCLUDES += -I$(EXEROOT)/$(COMPONENT)/source/inc -I$(INSTALL_SHAREDPATH)/include -I$(INSTALL_SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include override FCINCLUDES += -I$(EXEROOT)/$(COMPONENT)/source/inc -I$(INSTALL_SHAREDPATH)/include -I$(INSTALL_SHAREDPATH)/$(COMP_INTERFACE)/$(ESMFDIR)/$(NINST_VALUE)/csm_share -I$(NETCDF)/include -I$(PIO) -I$(PNETCDF)/include LIBS += -L$(PIO) -L$(PNETCDF)/lib -L$(NETCDF)/lib -L$(LIBROOT) -L$(INSTALL_SHAREDPATH)/lib -lpio -lpnetcdf -lnetcdf -ifneq (,$(findstring FORTRANUNDERSCORE, $(CPPFLAGS))) -ifeq (,$(findstring DUNDERSCORE, $(CPPFLAGS))) - override CPPFLAGS += -DUNDERSCORE -endif -endif - ifeq ($(DEBUG), TRUE) override CPPFLAGS += -DMPAS_DEBUG endif -ifeq ($(compile_threaded), true) +ifeq ($(compile_threaded), TRUE) override CPPFLAGS += -DMPAS_OPENMP endif +ifeq "$(GEN_F90)" "true" + override CPPFLAGS += -Uvector +endif + all: @echo $(CPPINCLUDES) @echo $(FCINCLUDES) diff --git a/src/core_atmosphere/CMakeLists.txt b/src/core_atmosphere/CMakeLists.txt new file mode 100644 index 0000000000..ac0d28f469 --- /dev/null +++ b/src/core_atmosphere/CMakeLists.txt @@ -0,0 +1,389 @@ + +## Source files +# physics/ +set(ATMOSPHERE_CORE_PHYSICS_SOURCES + ccpp_kind_types.F + mpas_atmphys_camrad_init.F + mpas_atmphys_constants.F + mpas_atmphys_control.F + mpas_atmphys_date_time.F + mpas_atmphys_driver_cloudiness.F + mpas_atmphys_driver_microphysics.F + mpas_atmphys_driver_oml.F + mpas_atmphys_finalize.F + mpas_atmphys_functions.F + mpas_atmphys_init_microphysics.F + mpas_atmphys_interface.F + mpas_atmphys_landuse.F + mpas_atmphys_lsm_noahinit.F + mpas_atmphys_manager.F + mpas_atmphys_o3climatology.F + mpas_atmphys_rrtmg_lwinit.F + mpas_atmphys_rrtmg_swinit.F + mpas_atmphys_update.F + mpas_atmphys_update_surface.F + mpas_atmphys_utilities.F + mpas_atmphys_driver.F + mpas_atmphys_driver_convection.F + mpas_atmphys_driver_gwdo.F + mpas_atmphys_driver_lsm.F + mpas_atmphys_driver_pbl.F + mpas_atmphys_driver_radiation_lw.F + mpas_atmphys_driver_radiation_sw.F + mpas_atmphys_driver_seaice.F + mpas_atmphys_driver_sfclayer.F + mpas_atmphys_init.F + mpas_atmphys_lsm_shared.F + mpas_atmphys_packages.F + mpas_atmphys_todynamics.F + mpas_atmphys_vars.F + mpas_atmphys_driver_lsm_noahmp.F + mpas_atmphys_lsm_noahmpfinalize.F + mpas_atmphys_lsm_noahmpinit.F +) +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_SOURCES PREPEND physics/) + +## Unused +# physics/physics_wrf/ +set(ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES + libmassv.F + cu_ntiedtke_post.F + cu_ntiedtke_pre.F + module_bep_bem_helper.F + module_bl_gwdo.F + module_bl_ysu.F + module_cam_error_function.F + module_cam_shr_kind_mod.F + module_cam_support.F + module_cu_gf.mpas.F + module_mp_kessler.F + module_mp_radar.F + module_mp_thompson.F + module_mp_thompson_cldfra3.F + module_mp_thompson_aerosols.F + module_mp_wsm6.F + module_ra_rrtmg_sw_aerosols.F + module_ra_cam_support.F + module_ra_rrtmg_lw.F + module_ra_rrtmg_sw.F + module_ra_rrtmg_vinterp.F + module_sf_bem.F + module_sf_bep.F + module_sf_bep_bem.F + module_sf_noah_seaice.F + module_sf_noah_seaice_drv.F + module_sf_noahdrv.F + module_sf_noahlsm.F + module_sf_noahlsm_glacial_only.F + module_sf_oml.F + module_sf_sfcdiags.F + module_sf_sfclay.F + module_sf_sfclayrev.F + module_sf_urban.F + bl_mynn_post.F + bl_mynn_pre.F + module_bl_mynn.F + module_cu_kfeta.F + module_cu_ntiedtke.F + module_cu_tiedtke.F + module_ra_cam.F + module_sf_mynn.F + sf_mynn_pre.F + sf_sfclayrev_pre.F +) + +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES PREPEND physics/physics_wrf/) + + +set(ATMOSPHERE_CORE_PHYSICS_MMM_DIR ${CMAKE_CURRENT_SOURCE_DIR}/physics/physics_mmm) + +if(NOT EXISTS ${ATMOSPHERE_CORE_PHYSICS_MMM_DIR}) + set(PHYSICS_MMM_REPO_URL "https://github.com/NCAR/MMM-physics") + execute_process(COMMAND git clone ${PHYSICS_MMM_REPO_URL} ${ATMOSPHERE_CORE_PHYSICS_MMM_DIR} + RESULT_VARIABLE GIT_CLONE_RESULT + OUTPUT_VARIABLE GIT_CLONE_OUTPUT + ERROR_VARIABLE GIT_CLONE_ERROR) + if(NOT GIT_CLONE_RESULT EQUAL 0) + message(FATAL_ERROR "Git clone failed with error: ${GIT_CLONE_ERROR}") + endif() + +else() + message(STATUS "Directory ${DIR_TO_CHECK} already exists, skipping clone") +endif() + +set(ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES + bl_gwdo.F90 + bl_ysu.F90 + cu_ntiedtke.F90 + module_libmassv.F90 + mp_wsm6.F90 + mp_wsm6_effectRad.F90 + bl_mynn.F90 + bl_mynn_subroutines.F90 + mp_radar.F90 + mynn_shared.F90 + sf_mynn.F90 + sf_sfclayrev.F90 +) + +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES PREPEND physics/physics_mmm/) + +set(ATMOSPHERE_CORE_PHYSICS_NOAMP_UTILITY_SOURCES + CheckNanMod.F90 + ErrorHandleMod.F90 + Machine.F90 +) +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_UTILITY_SOURCES PREPEND physics/physics_noahmp/utility/) + +set(ATMOSPHERE_CORE_PHYSICS_NOAMP_MPAS_DRIVER_SOURCES + BiochemVarInTransferMod.F90 + ConfigVarOutTransferMod.F90 + ForcingVarInTransferMod.F90 + NoahmpDriverMainMod.F90 + NoahmpIOVarFinalizeMod.F90 + NoahmpReadNamelistMod.F90 + PedoTransferSR2006Mod.F90 + BiochemVarOutTransferMod.F90 + EnergyVarInTransferMod.F90 + ForcingVarOutTransferMod.F90 + NoahmpIOVarInitMod.F90 + NoahmpReadTableMod.F90 + WaterVarInTransferMod.F90 + ConfigVarInTransferMod.F90 + EnergyVarOutTransferMod.F90 + NoahmpInitMainMod.F90 + NoahmpIOVarType.F90 + NoahmpSnowInitMod.F90 + WaterVarOutTransferMod.F90 +) +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_MPAS_DRIVER_SOURCES PREPEND physics/physics_noahmp/drivers/mpas/) + +set(ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES + AtmosForcingMod.F90 + BalanceErrorCheckGlacierMod.F90 + BalanceErrorCheckMod.F90 + BiochemCropMainMod.F90 + BiochemNatureVegMainMod.F90 + BiochemVarInitMod.F90 + BiochemVarType.F90 + CanopyHydrologyMod.F90 + CanopyRadiationTwoStreamMod.F90 + CanopyWaterInterceptMod.F90 + CarbonFluxCropMod.F90 + CarbonFluxNatureVegMod.F90 + ConfigVarInitMod.F90 + ConfigVarType.F90 + ConstantDefineMod.F90 + CropGrowDegreeDayMod.F90 + CropPhotosynthesisMod.F90 + EnergyMainGlacierMod.F90 + EnergyMainMod.F90 + EnergyVarInitMod.F90 + EnergyVarType.F90 + ForcingVarInitMod.F90 + ForcingVarType.F90 + GeneralInitGlacierMod.F90 + GeneralInitMod.F90 + GlacierIceThermalPropertyMod.F90 + GlacierPhaseChangeMod.F90 + GlacierTemperatureMainMod.F90 + GlacierTemperatureSolverMod.F90 + GlacierThermalDiffusionMod.F90 + GroundAlbedoGlacierMod.F90 + GroundAlbedoMod.F90 + GroundRoughnessPropertyGlacierMod.F90 + GroundRoughnessPropertyMod.F90 + GroundThermalPropertyGlacierMod.F90 + GroundThermalPropertyMod.F90 + GroundWaterMmfMod.F90 + GroundWaterTopModelMod.F90 + HumiditySaturationMod.F90 + IrrigationFloodMod.F90 + IrrigationInfilPhilipMod.F90 + IrrigationMicroMod.F90 + IrrigationPrepareMod.F90 + IrrigationSprinklerMod.F90 + IrrigationTriggerMod.F90 + Makefile + MatrixSolverTriDiagonalMod.F90 + NoahmpMainGlacierMod.F90 + NoahmpMainMod.F90 + NoahmpVarType.F90 + PhenologyMainMod.F90 + PrecipitationHeatAdvectGlacierMod.F90 + PrecipitationHeatAdvectMod.F90 + PsychrometricVariableGlacierMod.F90 + PsychrometricVariableMod.F90 + ResistanceAboveCanopyChen97Mod.F90 + ResistanceAboveCanopyMostMod.F90 + ResistanceBareGroundChen97Mod.F90 + ResistanceBareGroundMostMod.F90 + ResistanceCanopyStomataBallBerryMod.F90 + ResistanceCanopyStomataJarvisMod.F90 + ResistanceGroundEvaporationGlacierMod.F90 + ResistanceGroundEvaporationMod.F90 + ResistanceLeafToGroundMod.F90 + RunoffSubSurfaceDrainageMod.F90 + RunoffSubSurfaceEquiWaterTableMod.F90 + RunoffSubSurfaceGroundWaterMod.F90 + RunoffSubSurfaceShallowMmfMod.F90 + RunoffSurfaceBatsMod.F90 + RunoffSurfaceDynamicVicMod.F90 + RunoffSurfaceExcessDynamicVicMod.F90 + RunoffSurfaceFreeDrainMod.F90 + RunoffSurfaceTopModelEquiMod.F90 + RunoffSurfaceTopModelGrdMod.F90 + RunoffSurfaceTopModelMmfMod.F90 + RunoffSurfaceVicMod.F90 + RunoffSurfaceXinAnJiangMod.F90 + ShallowWaterTableMmfMod.F90 + SnowAgingBatsMod.F90 + SnowAlbedoBatsMod.F90 + SnowAlbedoClassMod.F90 + SnowCoverGlacierMod.F90 + SnowCoverGroundNiu07Mod.F90 + SnowfallBelowCanopyMod.F90 + SnowLayerCombineMod.F90 + SnowLayerDivideMod.F90 + SnowLayerWaterComboMod.F90 + SnowpackCompactionMod.F90 + SnowpackHydrologyGlacierMod.F90 + SnowpackHydrologyMod.F90 + SnowThermalPropertyMod.F90 + SnowWaterMainGlacierMod.F90 + SnowWaterMainMod.F90 + SoilHydraulicPropertyMod.F90 + SoilMoistureSolverMod.F90 + SoilSnowTemperatureMainMod.F90 + SoilSnowTemperatureSolverMod.F90 + SoilSnowThermalDiffusionMod.F90 + SoilSnowWaterPhaseChangeMod.F90 + SoilThermalPropertyMod.F90 + SoilWaterDiffusionRichardsMod.F90 + SoilWaterInfilGreenAmptMod.F90 + SoilWaterInfilPhilipMod.F90 + SoilWaterInfilSmithParlangeMod.F90 + SoilWaterMainMod.F90 + SoilWaterSupercoolKoren99Mod.F90 + SoilWaterSupercoolNiu06Mod.F90 + SoilWaterTranspirationMod.F90 + SurfaceAlbedoGlacierMod.F90 + SurfaceAlbedoMod.F90 + SurfaceEmissivityGlacierMod.F90 + SurfaceEmissivityMod.F90 + SurfaceEnergyFluxBareGroundMod.F90 + SurfaceEnergyFluxGlacierMod.F90 + SurfaceEnergyFluxVegetatedMod.F90 + SurfaceRadiationGlacierMod.F90 + SurfaceRadiationMod.F90 + TileDrainageEquiDepthMod.F90 + TileDrainageHooghoudtMod.F90 + TileDrainageSimpleMod.F90 + VaporPressureSaturationMod.F90 + WaterMainGlacierMod.F90 + WaterMainMod.F90 + WaterTableDepthSearchMod.F90 + WaterTableEquilibriumMod.F90 + WaterVarInitMod.F90 + WaterVarType.F90 +) +list(TRANSFORM ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES PREPEND physics/physics_noahmp/src/) + +# diagnostics/ +set(ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES + mpas_atm_diagnostic_template.F + mpas_atm_diagnostics_manager.F + mpas_atm_diagnostics_utils.F + mpas_cloud_diagnostics.F + mpas_convective_diagnostics.F + mpas_isobaric_diagnostics.F + mpas_pv_diagnostics.F + mpas_soundings.F +) + +list(TRANSFORM ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES PREPEND diagnostics/) + +# dynamics/ +set(ATMOSPHERE_CORE_DYNAMICS_SOURCES + mpas_atm_boundaries.F + mpas_atm_iau.F + mpas_atm_time_integration.F) +list(TRANSFORM ATMOSPHERE_CORE_DYNAMICS_SOURCES PREPEND dynamics/) + +# utils/ +set(ATMOSPHERE_CORE_UTILS_SOURCES + atmphys_build_tables_thompson.F + build_tables.F) +list(TRANSFORM ATMOSPHERE_CORE_UTILS_SOURCES PREPEND utils/) + +# core_atosphere +set(ATMOSPHERE_CORE_SOURCES + mpas_atm_dimensions.F + mpas_atm_threading.F + mpas_atm_core.F + mpas_atm_core_interface.F + mpas_atm_halos.F +) + +## Generated includes +set(ATMOSPHERE_CORE_INCLUDES + block_dimension_routines.inc + core_variables.inc + define_packages.inc + domain_variables.inc + namelist_call.inc + namelist_defines.inc + setup_immutable_streams.inc + structs_and_variables.inc) + + +add_library(core_atmosphere ${ATMOSPHERE_CORE_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_NOAMP_UTILITY_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_NOAMP_MPAS_DRIVER_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_NOAMP_SRC_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_MMM_SOURCES} + ${ATMOSPHERE_CORE_PHYSICS_WRF_SOURCES} + ${ATMOSPHERE_CORE_DIAGNOSTIC_SOURCES} + ${ATMOSPHERE_CORE_DYNAMICS_SOURCES}) + +set(CORE_ATMOSPHERE_COMPILE_DEFINITIONS + mpas=1 + MPAS_NATIVE_TIMERS +) +if (${DO_PHYSICS}) + list(APPEND CORE_ATMOSPHERE_COMPILE_DEFINITIONS DO_PHYSICS) +endif () +target_compile_definitions(core_atmosphere PRIVATE ${CORE_ATMOSPHERE_COMPILE_DEFINITIONS}) +set_MPAS_DEBUG_flag(core_atmosphere) +mpas_core_target(CORE atmosphere TARGET core_atmosphere INCLUDES ${ATMOSPHERE_CORE_INCLUDES}) + +#Get physics_wrf tables from MPAS-Data +include(FetchContent) +if (${PROJECT_VERSION} VERSION_GREATER_EQUAL 7.0) + set(MPAS_DATA_GIT_TAG v${PROJECT_VERSION_MAJOR}.0) +else () + set(MPAS_DATA_GIT_TAG master) +endif () + +FetchContent_Declare(mpas_data + GIT_REPOSITORY https://github.com/MPAS-Dev/MPAS-Data.git + GIT_TAG ${MPAS_DATA_GIT_TAG} + GIT_PROGRESS True + GIT_SHALLOW True) +FetchContent_Populate(mpas_data) +message(STATUS "MPAS-Data source dir: ${mpas_data_SOURCE_DIR}") +set(PHYSICS_WRF_DATA_DIR ${mpas_data_SOURCE_DIR}/atmosphere/physics_wrf/files) +file(GLOB PHYSICS_WRF_DATA RELATIVE ${PHYSICS_WRF_DATA_DIR} "${PHYSICS_WRF_DATA_DIR}/*") +file(MAKE_DIRECTORY ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/core_atmosphere) +foreach (data_file IN LISTS PHYSICS_WRF_DATA) + execute_process(COMMAND ${CMAKE_COMMAND} -E create_symlink ${PHYSICS_WRF_DATA_DIR}/${data_file} + ${CMAKE_BINARY_DIR}/${PROJECT_NAME}/core_atmosphere/${data_file}) +endforeach () +install(DIRECTORY ${PHYSICS_WRF_DATA_DIR}/ DESTINATION ${CMAKE_INSTALL_DATADIR}/${PROJECT_NAME}/core_atmosphere) + +add_executable(mpas_atmosphere_build_tables ${ATMOSPHERE_CORE_UTILS_SOURCES}) +target_link_libraries(mpas_atmosphere_build_tables PUBLIC core_atmosphere) +mpas_fortran_target(mpas_atmosphere_build_tables) +install(TARGETS mpas_atmosphere_build_tables EXPORT ${PROJECT_NAME}ExportsCore + RUNTIME DESTINATION ${CMAKE_INSTALL_BINDIR}) diff --git a/src/core_atmosphere/Externals.cfg b/src/core_atmosphere/Externals.cfg new file mode 100644 index 0000000000..3626ec3674 --- /dev/null +++ b/src/core_atmosphere/Externals.cfg @@ -0,0 +1,10 @@ +[MMM-physics] +local_path = ./physics_mmm +protocol = git +repo_url = https://github.com/NCAR/MMM-physics.git +tag = 20240626-MPASv8.2 + +required = True + +[externals_description] +schema_version = 1.0.0 diff --git a/src/core_atmosphere/Makefile b/src/core_atmosphere/Makefile index 2e77cf8846..8d9f4f1a39 100644 --- a/src/core_atmosphere/Makefile +++ b/src/core_atmosphere/Makefile @@ -1,27 +1,36 @@ .SUFFIXES: .F .o +# +# To build a dycore-only MPAS-Atmosphere model, comment-out or delete +# the definition of PHYSICS, below +# PHYSICS=-DDO_PHYSICS -#PHYSICS= + + +ifdef PHYSICS + PHYSCORE = physcore + PHYS_OBJS = libphys/*.o +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 +all: $(PHYSCORE) dycore diagcore atmcore utilities core_reg: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $(PHYSICS) Registry.xml > Registry_processed.xml 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: - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml +gen_includes: core_reg (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi @@ -33,22 +42,23 @@ physcore: mpas_atm_dimensions.o ( mkdir libphys; cd libphys; ar -x ../physics/libphys.a ) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*TBL .) ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_wrf/files/*DATA* .) + ( cd ../..; ln -sf ./src/core_atmosphere/physics/physics_noahmp/parameters/*TBL .) -dycore: mpas_atm_dimensions.o physcore +dycore: mpas_atm_dimensions.o $(PHYSCORE) ( cd dynamics; $(MAKE) all PHYSICS="$(PHYSICS)" ) -diagcore: physcore dycore - ( cd diagnostics; $(MAKE) all ) +diagcore: $(PHYSCORE) dycore + ( cd diagnostics; $(MAKE) all PHYSICS="$(PHYSICS)" ) -utilities: physcore - ( cd utils; $(MAKE) all ) +utilities: $(PHYSCORE) + ( cd utils; $(MAKE) all PHYSICS="$(PHYSICS)" ) -atmcore: physcore dycore diagcore $(OBJS) - ar -ru libdycore.a $(OBJS) dynamics/*.o libphys/*.o diagnostics/*.o +atmcore: $(PHYSCORE) dycore diagcore $(OBJS) + ar -ru libdycore.a $(OBJS) dynamics/*.o $(PHYS_OBJS) diagnostics/*.o 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: @@ -70,8 +80,8 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I../external/esmf_time_f90 + $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) -I./inc $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I./physics -I./dynamics -I./diagnostics -I./physics/physics_wrf -I./physics/physics_mmm -I../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/Registry.xml b/src/core_atmosphere/Registry.xml index 05c514360d..c8f654e377 100644 --- a/src/core_atmosphere/Registry.xml +++ b/src/core_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -32,6 +32,8 @@ description="The number of atmospheric layers"/> + +#ifdef DO_PHYSICS +#endif @@ -101,35 +104,35 @@ - - - - - - @@ -139,10 +142,10 @@ description="Formulation of horizontal mixing" possible_values="`2d_fixed' or `2d_smagorinsky'"/> - + possible_values="Positive real values. A zero value implies that the length scale is prescribed by the nominalMinDc value in the input file."/> - - - - - - - @@ -194,7 +197,7 @@ description="Whether to advect scalar fields" possible_values=".true. or .false."/> - @@ -243,6 +246,11 @@ units="-" description="Number of halo layers for fields" possible_values="Integer values, typically 2 or 3; DO NOT CHANGE"/> + + @@ -255,8 +263,40 @@ units="-" description="Maximum w-damping coefficient at model top" possible_values="0 $\leq$ config_xnutr $\leq$ 1"/> + + + + + + + + + + + + + + + + + + + + + @@ -344,14 +397,19 @@ + - + + + + + @@ -360,11 +418,12 @@ - + filename_template="invariant.nc" + input_interval="none" + immutable="true" + in_defaults="false"> @@ -407,6 +466,10 @@ + + + + @@ -421,16 +484,59 @@ - - - +#ifdef MPAS_CAM_DYCORE + + +#endif +#ifdef DO_PHYSICS + + + + + + + + + + + + + + + + + + + + + + + + + + +#endif + + + + + + + + + + @@ -439,15 +545,8 @@ - - - - - - - - - + +#ifdef DO_PHYSICS @@ -468,17 +567,8 @@ - - - - - - - - - - +#endif - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + - - - - - - +#ifdef MPAS_CAM_DYCORE + + +#endif - - - - - - - + @@ -572,8 +599,6 @@ - - @@ -588,6 +613,17 @@ + +#ifdef DO_PHYSICS + + + + + + + + + @@ -600,7 +636,9 @@ + + @@ -613,6 +651,7 @@ + @@ -622,6 +661,19 @@ + + + + + + + + + + + + + @@ -734,6 +786,18 @@ + + + + + + + + + + + + @@ -750,20 +814,13 @@ + + + + - - - - - - - - - - - @@ -780,16 +837,6 @@ - - - - - - - - - - @@ -797,6 +844,8 @@ + +#endif + @@ -867,6 +917,8 @@ + +#ifdef DO_PHYSICS @@ -878,7 +930,6 @@ - @@ -907,6 +958,8 @@ + + @@ -917,6 +970,7 @@ +#endif - - - - - - - - - - - - + + + + + + + + + + + + + + + + + @@ -997,6 +1056,21 @@ +#ifdef DO_PHYSICS + + + + + + + + + + + + +#endif + @@ -1017,6 +1091,7 @@ +#ifdef DO_PHYSICS @@ -1024,6 +1099,7 @@ +#endif +#ifdef DO_PHYSICS +#endif + + + + + + + + + + + + + + + + + + + + + + + + + + + + +#ifdef DO_PHYSICS + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +#endif + @@ -1193,12 +1357,21 @@ + + + + + + @@ -1263,6 +1436,9 @@ + + @@ -1274,10 +1450,10 @@ description="weights for cell-centered second derivative, normal to edge, for transport scheme"/> + description="Weighting coefficients used for reconstructing cell-based fields at edges"/> + description="Weighting coefficients used for reconstructing cell-based fields at edges"/> @@ -1292,6 +1468,14 @@ +#ifdef MPAS_CAM_DYCORE + + + +#endif + @@ -1301,6 +1485,34 @@ + + + + + + + + + + + + + + + @@ -1311,6 +1523,9 @@ + + @@ -1324,39 +1539,58 @@ + + + + +#ifndef MPAS_CAM_DYCORE + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + + + + + + +#endif +#ifdef DO_PHYSICS @@ -1395,6 +1629,7 @@ description="Volcanic (VOLC) aerosol concentration"/> +#endif @@ -1439,9 +1674,17 @@ + + + + @@ -1451,8 +1694,16 @@ - + + + + + @@ -1460,11 +1711,14 @@ - + - + + + - - @@ -1608,8 +1859,8 @@ - + @@ -1629,6 +1880,11 @@ + + + + +#ifndef MPAS_CAM_DYCORE + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;bl_ysu_in;cu_ntiedtke_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="bl_mynn_in;mp_thompson_in;mp_thompson_aers_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + + + + + + +#endif + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + @@ -1671,6 +2023,7 @@ +#ifdef DO_PHYSICS - @@ -1757,6 +2110,11 @@ description="logical for turning on/off top-down, radiation_driven mixing" possible_values=".true. to turn on top-down radiation_driven mixing; .false. otherwise"/> + + + possible_values="`suite',`mp_wsm6',`mp_thompson',`mp_thompson_aerosols', `mp_kessler',`off'"/> + possible_values="`suite',`sf_noah',`sf_noahmp`, `off'"/> + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_kessler_in;mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in;mp_wsm6_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + packages="mp_thompson_in;mp_thompson_aers_in"/> + + + + @@ -2004,19 +2454,19 @@ + 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"/> @@ -2085,14 +2535,6 @@ description="Planetary Boundary Layer (PBL) height" packages="bl_mynn_in;bl_ysu_in"/> - - - - @@ -2107,12 +2549,32 @@ + + + + + + + + + + @@ -2161,6 +2623,46 @@ description="TKE vertical distribution" packages="bl_mynn_in"/> + + + + + + + + + + + + + + + + + + + + @@ -2298,6 +2800,10 @@ description="stability function for heat" packages="bl_mynn_in"/> + + + + + + + + @@ -2572,13 +3087,26 @@ - + + + + + + + + + + @@ -2684,28 +3212,106 @@ description="ocean mixed layer integrated v (meridional velocity)"/> +#endif + + + + + + + + + + + + + +#ifdef DO_PHYSICS + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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"/> @@ -2720,19 +3326,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"/> @@ -2766,10 +3368,26 @@ description="tendency of cloud ice mixing ratio due to pbl processes" packages="bl_mynn_in;bl_ysu_in"/> + + + + + + + + @@ -2784,10 +3402,12 @@ description="tendency of potential temperature due to short wave radiation"/> + description="tendency of potential temperature due to long wave radiation"/> +#endif +#ifdef DO_PHYSICS + + + + @@ -2829,7 +3455,7 @@ description="terrain height"/> + description="monthly-mean climatological surface albedo"/> @@ -2887,36 +3513,37 @@ - + - + + description="asymmetry of subgrid-scale orography for westerly flow"/> + description="asymmetry of subgrid-scale orography for southerly flow"/> + description="asymmetry of subgrid-scale orography for south-westerly flow"/> + description="asymmetry of subgrid-scale orography for north-westerly flow"/> + description="effective orographic length for westerly flow"/> + description="effective orographic length for southerly flow"/> + description="effective orographic length for south-westerly flow"/> + description="effective orographic length for north-westerly flow"/> +#endif @@ -2931,22 +3558,28 @@ description="Potential temperature increment"/> - - - - - - @@ -2958,4 +3591,7 @@ #include "diagnostics/Registry_diagnostics.xml" +#ifdef DO_PHYSICS +#include "physics/Registry_noahmp.xml" +#endif diff --git a/src/core_atmosphere/build_options.mk b/src/core_atmosphere/build_options.mk index 34caf8d663..3b5a873451 100644 --- a/src/core_atmosphere/build_options.mk +++ b/src/core_atmosphere/build_options.mk @@ -2,6 +2,9 @@ PWD=$(shell pwd) EXE_NAME=atmosphere_model NAMELIST_SUFFIX=atmosphere override CPPFLAGS += -DCORE_ATMOSPHERE +FCINCLUDES += -I$(PWD)/src/core_atmosphere/physics/physics_noahmp/drivers/mpas \ + -I$(PWD)/src/core_atmosphere/physics/physics_noahmp/utility \ + -I$(PWD)/src/core_atmosphere/physics/physics_noahmp/src report_builds: @echo "CORE=atmosphere" diff --git a/src/core_atmosphere/diagnostics/Makefile b/src/core_atmosphere/diagnostics/Makefile index 9d83d39c6b..614bc1c137 100644 --- a/src/core_atmosphere/diagnostics/Makefile +++ b/src/core_atmosphere/diagnostics/Makefile @@ -5,18 +5,21 @@ # DIAGNOSTIC_MODULES = \ mpas_atm_diagnostic_template.o \ - isobaric_diagnostics.o \ - convective_diagnostics.o \ - pv_diagnostics.o \ - soundings.o \ + mpas_isobaric_diagnostics.o \ + mpas_cloud_diagnostics.o \ + mpas_convective_diagnostics.o \ + mpas_pv_diagnostics.o \ + mpas_soundings.o \ -isobaric_diagnostics.o: mpas_atm_diagnostics_utils.o +mpas_isobaric_diagnostics.o: mpas_atm_diagnostics_utils.o -convective_diagnostics.o: mpas_atm_diagnostics_utils.o +mpas_cloud_diagnostics.o: mpas_atm_diagnostics_utils.o -pv_diagnostics.o: mpas_atm_diagnostics_utils.o +mpas_convective_diagnostics.o: mpas_atm_diagnostics_utils.o -soundings.o: +mpas_pv_diagnostics.o: mpas_atm_diagnostics_utils.o + +mpas_soundings.o: ################### Generally no need to modify below here ################### @@ -24,7 +27,7 @@ soundings.o: OBJS = mpas_atm_diagnostics_manager.o mpas_atm_diagnostics_utils.o -all: $(DIAGNOSTIC_MODULS) $(OBJS) +all: $(DIAGNOSTIC_MODULES) $(OBJS) mpas_atm_diagnostics_manager.o: mpas_atm_diagnostics_utils.o $(DIAGNOSTIC_MODULES) diff --git a/src/core_atmosphere/diagnostics/README b/src/core_atmosphere/diagnostics/README index e7ed654859..89fdfa66e7 100644 --- a/src/core_atmosphere/diagnostics/README +++ b/src/core_atmosphere/diagnostics/README @@ -9,7 +9,8 @@ generally required to implement a diagnostic. Registry_diagnostics.xml. 2) Create a new module for the diagnostic; the "mpas_atm_diagnostic_template.F" - module file may be used as a template. + module file may be used as a template. By convention, the file and module + names are expected to begin with "mpas_". 3) Add calls to the diagnostic's "setup", "update", "compute", "reset", and "cleanup" routines in the main diagnostic driver. Note that some diagnostics diff --git a/src/core_atmosphere/diagnostics/Registry_cloud.xml b/src/core_atmosphere/diagnostics/Registry_cloud.xml new file mode 100644 index 0000000000..54728477de --- /dev/null +++ b/src/core_atmosphere/diagnostics/Registry_cloud.xml @@ -0,0 +1,20 @@ + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml index 8d2b815842..b9e7dc5682 100644 --- a/src/core_atmosphere/diagnostics/Registry_diagnostics.xml +++ b/src/core_atmosphere/diagnostics/Registry_diagnostics.xml @@ -7,6 +7,9 @@ #include "Registry_isobaric.xml" + +#include "Registry_cloud.xml" + #include "Registry_convective.xml" diff --git a/src/core_atmosphere/diagnostics/Registry_isobaric.xml b/src/core_atmosphere/diagnostics/Registry_isobaric.xml index daa758706b..853be6cde3 100644 --- a/src/core_atmosphere/diagnostics/Registry_isobaric.xml +++ b/src/core_atmosphere/diagnostics/Registry_isobaric.xml @@ -16,6 +16,12 @@ + + + + @@ -34,6 +40,12 @@ + + + + @@ -52,6 +64,12 @@ + + + + @@ -70,6 +88,12 @@ + + + + @@ -88,6 +112,12 @@ + + + + @@ -106,6 +136,12 @@ + + + + @@ -124,6 +160,12 @@ + + + + @@ -142,6 +184,12 @@ + + + + diff --git a/src/core_atmosphere/diagnostics/Registry_pv.xml b/src/core_atmosphere/diagnostics/Registry_pv.xml index fdf5d3b674..d776ec2a15 100644 --- a/src/core_atmosphere/diagnostics/Registry_pv.xml +++ b/src/core_atmosphere/diagnostics/Registry_pv.xml @@ -20,6 +20,10 @@ + + +#ifdef DO_PHYSICS @@ -32,9 +36,6 @@ - - @@ -58,9 +59,10 @@ +#endif - + diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F index 85c4876633..e1b13133ee 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostic_template.F @@ -5,7 +5,7 @@ ! 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 diagnostic_template +module mpas_diagnostic_template use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type @@ -134,4 +134,4 @@ subroutine diagnostic_template_cleanup() end subroutine diagnostic_template_cleanup -end module diagnostic_template +end module mpas_diagnostic_template diff --git a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F index 4af098ce1b..fb57411d1d 100644 --- a/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F +++ b/src/core_atmosphere/diagnostics/mpas_atm_diagnostics_manager.F @@ -32,11 +32,12 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) use mpas_atm_diagnostics_utils, only : mpas_atm_diag_utils_init use mpas_derived_types, only : MPAS_streamManager_type, MPAS_pool_type, MPAS_clock_type, dm_info - use diagnostic_template, only : diagnostic_template_setup - use isobaric_diagnostics, only : isobaric_diagnostics_setup - use convective_diagnostics, only : convective_diagnostics_setup - use pv_diagnostics, only : pv_diagnostics_setup - use soundings, only : soundings_setup + use mpas_diagnostic_template, only : diagnostic_template_setup + use mpas_isobaric_diagnostics, only : isobaric_diagnostics_setup + use mpas_cloud_diagnostics, only : cloud_diagnostics_setup + use mpas_convective_diagnostics, only : convective_diagnostics_setup + use mpas_pv_diagnostics, only : pv_diagnostics_setup + use mpas_soundings, only : soundings_setup implicit none @@ -54,6 +55,7 @@ subroutine mpas_atm_diag_setup(stream_mgr, configs, structs, clock, dminfo) call diagnostic_template_setup(configs, structs, clock) call isobaric_diagnostics_setup(structs, clock) + call cloud_diagnostics_setup(structs, clock) call convective_diagnostics_setup(structs, clock) call pv_diagnostics_setup(structs, clock) call soundings_setup(configs, structs, clock, dminfo) @@ -73,8 +75,8 @@ end subroutine mpas_atm_diag_setup !----------------------------------------------------------------------- subroutine mpas_atm_diag_update() - use diagnostic_template, only : diagnostic_template_update - use convective_diagnostics, only : convective_diagnostics_update + use mpas_diagnostic_template, only : diagnostic_template_update + use mpas_convective_diagnostics, only : convective_diagnostics_update implicit none @@ -97,17 +99,19 @@ end subroutine mpas_atm_diag_update !----------------------------------------------------------------------- subroutine mpas_atm_diag_compute() - use diagnostic_template, only : diagnostic_template_compute - use isobaric_diagnostics, only : isobaric_diagnostics_compute - use convective_diagnostics, only : convective_diagnostics_compute - use pv_diagnostics, only : pv_diagnostics_compute - use soundings, only : soundings_compute + use mpas_diagnostic_template, only : diagnostic_template_compute + use mpas_isobaric_diagnostics, only : isobaric_diagnostics_compute + use mpas_cloud_diagnostics, only : cloud_diagnostics_compute + use mpas_convective_diagnostics, only : convective_diagnostics_compute + use mpas_pv_diagnostics, only : pv_diagnostics_compute + use mpas_soundings, only : soundings_compute implicit none call diagnostic_template_compute() call isobaric_diagnostics_compute() + call cloud_diagnostics_compute() call convective_diagnostics_compute() call pv_diagnostics_compute() call soundings_compute() @@ -127,8 +131,8 @@ end subroutine mpas_atm_diag_compute !----------------------------------------------------------------------- subroutine mpas_atm_diag_reset() - use diagnostic_template, only : diagnostic_template_reset - use convective_diagnostics, only : convective_diagnostics_reset + use mpas_diagnostic_template, only : diagnostic_template_reset + use mpas_convective_diagnostics, only : convective_diagnostics_reset implicit none @@ -152,8 +156,8 @@ end subroutine mpas_atm_diag_reset subroutine mpas_atm_diag_cleanup() use mpas_atm_diagnostics_utils, only : mpas_atm_diag_utils_finalize - use diagnostic_template, only : diagnostic_template_cleanup - use soundings, only : soundings_cleanup + use mpas_diagnostic_template, only : diagnostic_template_cleanup + use mpas_soundings, only : soundings_cleanup implicit none diff --git a/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F new file mode 100644 index 0000000000..b4de3b3e75 --- /dev/null +++ b/src/core_atmosphere/diagnostics/mpas_cloud_diagnostics.F @@ -0,0 +1,143 @@ +! Copyright (c) 2022, 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_cloud_diagnostics + + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type + use mpas_kind_types, only : RKIND + + type (MPAS_pool_type), pointer :: mesh + type (MPAS_pool_type), pointer :: diag + type (MPAS_pool_type), pointer :: diag_physics + + type (MPAS_clock_type), pointer :: clock + + public :: cloud_diagnostics_setup, & + cloud_diagnostics_compute, & + + private + + + contains + + + !----------------------------------------------------------------------- + ! routine cloud_diagnostics_setup + ! + !> \brief Initialize the cloud diagnostic module + !> \author G. Dylan Dickerson + !> \date 23 August 2022 + !> \details + !> Initialize the diagnostic and save pointers to subpools for + !> reuse in this module + ! + !----------------------------------------------------------------------- + subroutine cloud_diagnostics_setup(all_pools, simulation_clock) + + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type + use mpas_pool_routines, only : mpas_pool_get_subpool + + implicit none + + type (MPAS_pool_type), pointer :: all_pools + type (MPAS_clock_type), pointer :: simulation_clock + + + call mpas_pool_get_subpool(all_pools, 'mesh', mesh) + call mpas_pool_get_subpool(all_pools, 'diag', diag) + call mpas_pool_get_subpool(all_pools, 'diag_physics', diag_physics) + + clock => simulation_clock + + end subroutine cloud_diagnostics_setup + + + !----------------------------------------------------------------------- + ! routine cloud_diagnostics_compute + ! + !> \brief Compute diagnostic before model output is written + !> \author G. Dylan Dickerson + !> \date 23 August 2022 + !> \details + !> Compute diagnostic before model output is written + !> The following fields are computed by this routine: + !> cldfrac_low_UPP + !> cldfrac_mid_UPP + !> cldfrac_high_UPP + !> cldfrac_tot_UPP + ! + !----------------------------------------------------------------------- + subroutine cloud_diagnostics_compute() + + use mpas_atm_diagnostics_utils, only : MPAS_field_will_be_written + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + + implicit none + + integer :: iCell, k + integer, pointer :: nCellsSolve, nVertLevels + + real (kind=RKIND), dimension(:), pointer :: cldfrac_low_UPP + real (kind=RKIND), dimension(:), pointer :: cldfrac_mid_UPP + real (kind=RKIND), dimension(:), pointer :: cldfrac_high_UPP + real (kind=RKIND), dimension(:), pointer :: cldfrac_tot_UPP + + real (kind=RKIND), dimension(:), allocatable :: p_in + real (kind=RKIND), dimension(:,:), pointer :: pressure_p + real (kind=RKIND), dimension(:,:), pointer :: pressure_base + real (kind=RKIND), dimension(:,:), pointer :: cldfrac + + ! levels for low/mid/high cloud fraction - UPP method + real (kind=RKIND), parameter :: ptop_low = 64200.0, ptop_mid = 35000.0, ptop_high = 15000.0 + + logical :: need_cldfrac_UPP + + + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_low_UPP') + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_mid_UPP') .or. need_cldfrac_UPP + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_high_UPP') .or. need_cldfrac_UPP + need_cldfrac_UPP = MPAS_field_will_be_written('cldfrac_tot_UPP') .or. need_cldfrac_UPP + + if (need_cldfrac_UPP) then + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + call mpas_pool_get_array(diag, 'cldfrac_low_UPP', cldfrac_low_UPP) + call mpas_pool_get_array(diag, 'cldfrac_mid_UPP', cldfrac_mid_UPP) + call mpas_pool_get_array(diag, 'cldfrac_high_UPP', cldfrac_high_UPP) + call mpas_pool_get_array(diag, 'cldfrac_tot_UPP', cldfrac_tot_UPP) + + call mpas_pool_get_array(diag, 'pressure_base', pressure_base) + call mpas_pool_get_array(diag, 'pressure_p', pressure_p) + call mpas_pool_get_array(diag_physics, 'cldfrac', cldfrac) + + allocate(p_in(nVertLevels)) + + do iCell = 1, nCellsSolve + cldfrac_low_UPP (iCell) = 0.0 + cldfrac_mid_UPP (iCell) = 0.0 + cldfrac_high_UPP(iCell) = 0.0 + cldfrac_tot_UPP (iCell) = 0.0 + p_in(1:nVertLevels) = pressure_p(1:nVertLevels,iCell) + pressure_base(1:nVertLevels,iCell) + do k = 1, nVertLevels + if ( p_in(k) >= ptop_low ) then + cldfrac_low_UPP(iCell) = max(cldfrac_low_UPP(iCell), cldfrac(k,iCell)) + else if ( p_in(k) < ptop_low .and. p_in(k) >= ptop_mid ) then + cldfrac_mid_UPP(iCell) = max(cldfrac_mid_UPP(iCell), cldfrac(k,iCell)) + else if ( p_in(k) < ptop_mid .and. p_in(k) >= ptop_high ) then + cldfrac_high_UPP(iCell) = max(cldfrac_high_UPP(iCell), cldfrac(k,iCell)) + end if + cldfrac_tot_UPP(iCell) = max(cldfrac_tot_UPP(iCell), cldfrac(k,iCell)) + end do + end do + + deallocate(p_in) + + end if ! need_cldfrac_UPP + + end subroutine cloud_diagnostics_compute + +end module mpas_cloud_diagnostics diff --git a/src/core_atmosphere/diagnostics/convective_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_convective_diagnostics.F similarity index 99% rename from src/core_atmosphere/diagnostics/convective_diagnostics.F rename to src/core_atmosphere/diagnostics/mpas_convective_diagnostics.F index 9554113e4e..163ee3774f 100644 --- a/src/core_atmosphere/diagnostics/convective_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_convective_diagnostics.F @@ -5,10 +5,10 @@ ! 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 convective_diagnostics +module mpas_convective_diagnostics use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, MPAS_LOG_ERR, MPAS_LOG_CRIT - use mpas_kind_types, only : RKIND + use mpas_kind_types, only : RKIND, R8KIND use mpas_log, only : mpas_log_write type (MPAS_pool_type), pointer :: mesh @@ -669,7 +669,7 @@ subroutine getcape( nk , p_in , t_in , td_in, cape , cin ) real (kind=RKIND) :: th1,p1,t1,qv1,ql1,qi1,b1,pi1,thv1,qt,dp,dz,ps,frac real (kind=RKIND) :: th2,p2,t2,qv2,ql2,qi2,b2,pi2,thv2 real (kind=RKIND) :: thlast,fliq,fice,tbar,qvbar,qlbar,qibar,lhv,lhs,lhf,rm,cpm - real*8 :: avgth,avgqv + real (kind=R8KIND) :: avgth,avgqv ! real (kind=RKIND) :: getqvs,getqvi,getthe !----------------------------------------------------------------------- @@ -1096,4 +1096,4 @@ end function getthe !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !----------------------------------------------------------------------- -end module convective_diagnostics +end module mpas_convective_diagnostics diff --git a/src/core_atmosphere/diagnostics/isobaric_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F similarity index 83% rename from src/core_atmosphere/diagnostics/isobaric_diagnostics.F rename to src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F index c7aa9b568c..e52c71b125 100644 --- a/src/core_atmosphere/diagnostics/isobaric_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_isobaric_diagnostics.F @@ -5,7 +5,7 @@ ! 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 isobaric_diagnostics +module mpas_isobaric_diagnostics use mpas_dmpar use mpas_kind_types @@ -26,14 +26,14 @@ module isobaric_diagnostics private logical :: need_mslp, & - need_relhum_200, need_relhum_250, need_relhum_500, need_relhum_700, need_relhum_850, need_relhum_925, & - need_dewpoint_200, need_dewpoint_250, need_dewpoint_500, need_dewpoint_700, need_dewpoint_850, need_dewpoint_925, & - need_temp_200, need_temp_250, need_temp_500, need_temp_700, need_temp_850, need_temp_925, & - need_height_200, need_height_250, need_height_500, need_height_700, need_height_850, need_height_925, & - need_uzonal_200, need_uzonal_250, need_uzonal_500, need_uzonal_700, need_uzonal_850, need_uzonal_925, & - need_umeridional_200, need_umeridional_250, need_umeridional_500, need_umeridional_700, need_umeridional_850, need_umeridional_925, & - need_w_200, need_w_250, need_w_500, need_w_700, need_w_850, need_w_925, & - need_vorticity_200, need_vorticity_250, need_vorticity_500, need_vorticity_700, need_vorticity_850, need_vorticity_925, & + need_relhum_50, need_relhum_100, need_relhum_200, need_relhum_250, need_relhum_500, need_relhum_700, need_relhum_850, need_relhum_925, & + need_dewpoint_50, need_dewpoint_100, need_dewpoint_200, need_dewpoint_250, need_dewpoint_500, need_dewpoint_700, need_dewpoint_850, need_dewpoint_925, & + need_temp_50, need_temp_100, need_temp_200, need_temp_250, need_temp_500, need_temp_700, need_temp_850, need_temp_925, & + need_height_50, need_height_100, need_height_200, need_height_250, need_height_500, need_height_700, need_height_850, need_height_925, & + need_uzonal_50, need_uzonal_100, need_uzonal_200, need_uzonal_250, need_uzonal_500, need_uzonal_700, need_uzonal_850, need_uzonal_925, & + need_umeridional_50, need_umeridional_100, need_umeridional_200, need_umeridional_250, need_umeridional_500, need_umeridional_700, need_umeridional_850, need_umeridional_925, & + need_w_50, need_w_100, need_w_200, need_w_250, need_w_500, need_w_700, need_w_850, need_w_925, & + need_vorticity_50, need_vorticity_100, need_vorticity_200, need_vorticity_250, need_vorticity_500, need_vorticity_700, need_vorticity_850, need_vorticity_925, & need_t_isobaric, need_z_isobaric, need_meanT_500_300 logical :: need_temp, need_relhum, need_dewpoint, need_w, need_uzonal, need_umeridional, need_vorticity, need_height @@ -103,6 +103,12 @@ subroutine isobaric_diagnostics_compute() need_mslp = MPAS_field_will_be_written('mslp') need_any_diags = need_any_diags .or. need_mslp + need_relhum_50 = MPAS_field_will_be_written('relhum_50hPa') + need_relhum = need_relhum .or. need_relhum_50 + need_any_diags = need_any_diags .or. need_relhum_50 + need_relhum_100 = MPAS_field_will_be_written('relhum_100hPa') + need_relhum = need_relhum .or. need_relhum_100 + need_any_diags = need_any_diags .or. need_relhum_100 need_relhum_200 = MPAS_field_will_be_written('relhum_200hPa') need_relhum = need_relhum .or. need_relhum_200 need_any_diags = need_any_diags .or. need_relhum_200 @@ -121,6 +127,12 @@ subroutine isobaric_diagnostics_compute() need_relhum_925 = MPAS_field_will_be_written('relhum_925hPa') need_relhum = need_relhum .or. need_relhum_925 need_any_diags = need_any_diags .or. need_relhum_925 + need_dewpoint_50 = MPAS_field_will_be_written('dewpoint_50hPa') + need_dewpoint = need_dewpoint .or. need_dewpoint_50 + need_any_diags = need_any_diags .or. need_dewpoint_50 + need_dewpoint_100 = MPAS_field_will_be_written('dewpoint_100hPa') + need_dewpoint = need_dewpoint .or. need_dewpoint_100 + need_any_diags = need_any_diags .or. need_dewpoint_100 need_dewpoint_200 = MPAS_field_will_be_written('dewpoint_200hPa') need_dewpoint = need_dewpoint .or. need_dewpoint_200 need_any_diags = need_any_diags .or. need_dewpoint_200 @@ -139,6 +151,12 @@ subroutine isobaric_diagnostics_compute() need_dewpoint_925 = MPAS_field_will_be_written('dewpoint_925hPa') need_dewpoint = need_dewpoint .or. need_dewpoint_925 need_any_diags = need_any_diags .or. need_dewpoint_925 + need_temp_50 = MPAS_field_will_be_written('temperature_50hPa') + need_temp = need_temp .or. need_temp_50 + need_any_diags = need_any_diags .or. need_temp_50 + need_temp_100 = MPAS_field_will_be_written('temperature_100hPa') + need_temp = need_temp .or. need_temp_100 + need_any_diags = need_any_diags .or. need_temp_100 need_temp_200 = MPAS_field_will_be_written('temperature_200hPa') need_temp = need_temp .or. need_temp_200 need_any_diags = need_any_diags .or. need_temp_200 @@ -157,6 +175,12 @@ subroutine isobaric_diagnostics_compute() need_temp_925 = MPAS_field_will_be_written('temperature_925hPa') need_temp = need_temp .or. need_temp_925 need_any_diags = need_any_diags .or. need_temp_925 + need_height_50 = MPAS_field_will_be_written('height_50hPa') + need_height = need_height .or. need_height_50 + need_any_diags = need_any_diags .or. need_height_50 + need_height_100 = MPAS_field_will_be_written('height_100hPa') + need_height = need_height .or. need_height_100 + need_any_diags = need_any_diags .or. need_height_100 need_height_200 = MPAS_field_will_be_written('height_200hPa') need_height = need_height .or. need_height_200 need_any_diags = need_any_diags .or. need_height_200 @@ -175,6 +199,12 @@ subroutine isobaric_diagnostics_compute() need_height_925 = MPAS_field_will_be_written('height_925hPa') need_height = need_height .or. need_height_925 need_any_diags = need_any_diags .or. need_height_925 + need_uzonal_50 = MPAS_field_will_be_written('uzonal_50hPa') + need_uzonal = need_uzonal .or. need_uzonal_50 + need_any_diags = need_any_diags .or. need_uzonal_50 + need_uzonal_100 = MPAS_field_will_be_written('uzonal_100hPa') + need_uzonal = need_uzonal .or. need_uzonal_100 + need_any_diags = need_any_diags .or. need_uzonal_100 need_uzonal_200 = MPAS_field_will_be_written('uzonal_200hPa') need_uzonal = need_uzonal .or. need_uzonal_200 need_any_diags = need_any_diags .or. need_uzonal_200 @@ -193,6 +223,12 @@ subroutine isobaric_diagnostics_compute() need_uzonal_925 = MPAS_field_will_be_written('uzonal_925hPa') need_uzonal = need_uzonal .or. need_uzonal_925 need_any_diags = need_any_diags .or. need_uzonal_925 + need_umeridional_50 = MPAS_field_will_be_written('umeridional_50hPa') + need_umeridional = need_umeridional .or. need_umeridional_50 + need_any_diags = need_any_diags .or. need_umeridional_50 + need_umeridional_100 = MPAS_field_will_be_written('umeridional_100hPa') + need_umeridional = need_umeridional .or. need_umeridional_100 + need_any_diags = need_any_diags .or. need_umeridional_100 need_umeridional_200 = MPAS_field_will_be_written('umeridional_200hPa') need_umeridional = need_umeridional .or. need_umeridional_200 need_any_diags = need_any_diags .or. need_umeridional_200 @@ -211,6 +247,12 @@ subroutine isobaric_diagnostics_compute() need_umeridional_925 = MPAS_field_will_be_written('umeridional_925hPa') need_umeridional = need_umeridional .or. need_umeridional_925 need_any_diags = need_any_diags .or. need_umeridional_925 + need_w_50 = MPAS_field_will_be_written('w_50hPa') + need_w = need_w .or. need_w_50 + need_any_diags = need_any_diags .or. need_w_50 + need_w_100 = MPAS_field_will_be_written('w_100hPa') + need_w = need_w .or. need_w_100 + need_any_diags = need_any_diags .or. need_w_100 need_w_200 = MPAS_field_will_be_written('w_200hPa') need_w = need_w .or. need_w_200 need_any_diags = need_any_diags .or. need_w_200 @@ -229,6 +271,12 @@ subroutine isobaric_diagnostics_compute() need_w_925 = MPAS_field_will_be_written('w_925hPa') need_w = need_w .or. need_w_925 need_any_diags = need_any_diags .or. need_w_925 + need_vorticity_50 = MPAS_field_will_be_written('vorticity_50hPa') + need_vorticity = need_vorticity .or. need_vorticity_50 + need_any_diags = need_any_diags .or. need_vorticity_50 + need_vorticity_100 = MPAS_field_will_be_written('vorticity_100hPa') + need_vorticity = need_vorticity .or. need_vorticity_100 + need_any_diags = need_any_diags .or. need_vorticity_100 need_vorticity_200 = MPAS_field_will_be_written('vorticity_200hPa') need_vorticity = need_vorticity .or. need_vorticity_200 need_any_diags = need_any_diags .or. need_vorticity_200 @@ -297,6 +345,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:,:), pointer :: z_isobaric real (kind=RKIND), dimension(:), pointer :: meanT_500_300 + real (kind=RKIND), dimension(:), pointer :: temperature_50hPa + real (kind=RKIND), dimension(:), pointer :: temperature_100hPa real (kind=RKIND), dimension(:), pointer :: temperature_200hPa real (kind=RKIND), dimension(:), pointer :: temperature_250hPa real (kind=RKIND), dimension(:), pointer :: temperature_500hPa @@ -304,6 +354,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: temperature_850hPa real (kind=RKIND), dimension(:), pointer :: temperature_925hPa + real (kind=RKIND), dimension(:), pointer :: relhum_50hPa + real (kind=RKIND), dimension(:), pointer :: relhum_100hPa real (kind=RKIND), dimension(:), pointer :: relhum_200hPa real (kind=RKIND), dimension(:), pointer :: relhum_250hPa real (kind=RKIND), dimension(:), pointer :: relhum_500hPa @@ -311,6 +363,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: relhum_850hPa real (kind=RKIND), dimension(:), pointer :: relhum_925hPa + real (kind=RKIND), dimension(:), pointer :: dewpoint_50hPa + real (kind=RKIND), dimension(:), pointer :: dewpoint_100hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_200hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_250hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_500hPa @@ -318,6 +372,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: dewpoint_850hPa real (kind=RKIND), dimension(:), pointer :: dewpoint_925hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_50hPa + real (kind=RKIND), dimension(:), pointer :: uzonal_100hPa real (kind=RKIND), dimension(:), pointer :: uzonal_200hPa real (kind=RKIND), dimension(:), pointer :: uzonal_250hPa real (kind=RKIND), dimension(:), pointer :: uzonal_500hPa @@ -325,6 +381,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: uzonal_850hPa real (kind=RKIND), dimension(:), pointer :: uzonal_925hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_50hPa + real (kind=RKIND), dimension(:), pointer :: umeridional_100hPa real (kind=RKIND), dimension(:), pointer :: umeridional_200hPa real (kind=RKIND), dimension(:), pointer :: umeridional_250hPa real (kind=RKIND), dimension(:), pointer :: umeridional_500hPa @@ -332,6 +390,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: umeridional_850hPa real (kind=RKIND), dimension(:), pointer :: umeridional_925hPa + real (kind=RKIND), dimension(:), pointer :: height_50hPa + real (kind=RKIND), dimension(:), pointer :: height_100hPa real (kind=RKIND), dimension(:), pointer :: height_200hPa real (kind=RKIND), dimension(:), pointer :: height_250hPa real (kind=RKIND), dimension(:), pointer :: height_500hPa @@ -339,6 +399,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: height_850hPa real (kind=RKIND), dimension(:), pointer :: height_925hPa + real (kind=RKIND), dimension(:), pointer :: w_50hPa + real (kind=RKIND), dimension(:), pointer :: w_100hPa real (kind=RKIND), dimension(:), pointer :: w_200hPa real (kind=RKIND), dimension(:), pointer :: w_250hPa real (kind=RKIND), dimension(:), pointer :: w_500hPa @@ -346,6 +408,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) real (kind=RKIND), dimension(:), pointer :: w_850hPa real (kind=RKIND), dimension(:), pointer :: w_925hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_50hPa + real (kind=RKIND), dimension(:), pointer :: vorticity_100hPa real (kind=RKIND), dimension(:), pointer :: vorticity_200hPa real (kind=RKIND), dimension(:), pointer :: vorticity_250hPa real (kind=RKIND), dimension(:), pointer :: vorticity_500hPa @@ -411,6 +475,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'z_isobaric', z_isobaric) call mpas_pool_get_array(diag, 'meanT_500_300', meanT_500_300) + call mpas_pool_get_array(diag, 'temperature_50hPa', temperature_50hPa) + call mpas_pool_get_array(diag, 'temperature_100hPa', temperature_100hPa) call mpas_pool_get_array(diag, 'temperature_200hPa', temperature_200hPa) call mpas_pool_get_array(diag, 'temperature_250hPa', temperature_250hPa) call mpas_pool_get_array(diag, 'temperature_500hPa', temperature_500hPa) @@ -418,6 +484,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'temperature_850hPa', temperature_850hPa) call mpas_pool_get_array(diag, 'temperature_925hPa', temperature_925hPa) + call mpas_pool_get_array(diag, 'relhum_50hPa', relhum_50hPa) + call mpas_pool_get_array(diag, 'relhum_100hPa', relhum_100hPa) call mpas_pool_get_array(diag, 'relhum_200hPa', relhum_200hPa) call mpas_pool_get_array(diag, 'relhum_250hPa', relhum_250hPa) call mpas_pool_get_array(diag, 'relhum_500hPa', relhum_500hPa) @@ -425,6 +493,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'relhum_850hPa', relhum_850hPa) call mpas_pool_get_array(diag, 'relhum_925hPa', relhum_925hPa) + call mpas_pool_get_array(diag, 'dewpoint_50hPa', dewpoint_50hPa) + call mpas_pool_get_array(diag, 'dewpoint_100hPa', dewpoint_100hPa) call mpas_pool_get_array(diag, 'dewpoint_200hPa', dewpoint_200hPa) call mpas_pool_get_array(diag, 'dewpoint_250hPa', dewpoint_250hPa) call mpas_pool_get_array(diag, 'dewpoint_500hPa', dewpoint_500hPa) @@ -432,6 +502,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'dewpoint_850hPa', dewpoint_850hPa) call mpas_pool_get_array(diag, 'dewpoint_925hPa', dewpoint_925hPa) + call mpas_pool_get_array(diag, 'uzonal_50hPa', uzonal_50hPa) + call mpas_pool_get_array(diag, 'uzonal_100hPa', uzonal_100hPa) call mpas_pool_get_array(diag, 'uzonal_200hPa', uzonal_200hPa) call mpas_pool_get_array(diag, 'uzonal_250hPa', uzonal_250hPa) call mpas_pool_get_array(diag, 'uzonal_500hPa', uzonal_500hPa) @@ -439,6 +511,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'uzonal_850hPa', uzonal_850hPa) call mpas_pool_get_array(diag, 'uzonal_925hPa', uzonal_925hPa) + call mpas_pool_get_array(diag, 'umeridional_50hPa', umeridional_50hPa) + call mpas_pool_get_array(diag, 'umeridional_100hPa', umeridional_100hPa) call mpas_pool_get_array(diag, 'umeridional_200hPa', umeridional_200hPa) call mpas_pool_get_array(diag, 'umeridional_250hPa', umeridional_250hPa) call mpas_pool_get_array(diag, 'umeridional_500hPa', umeridional_500hPa) @@ -446,6 +520,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'umeridional_850hPa', umeridional_850hPa) call mpas_pool_get_array(diag, 'umeridional_925hPa', umeridional_925hPa) + call mpas_pool_get_array(diag, 'height_50hPa', height_50hPa) + call mpas_pool_get_array(diag, 'height_100hPa', height_100hPa) call mpas_pool_get_array(diag, 'height_200hPa', height_200hPa) call mpas_pool_get_array(diag, 'height_250hPa', height_250hPa) call mpas_pool_get_array(diag, 'height_500hPa', height_500hPa) @@ -453,6 +529,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'height_850hPa', height_850hPa) call mpas_pool_get_array(diag, 'height_925hPa', height_925hPa) + call mpas_pool_get_array(diag, 'w_50hPa', w_50hPa) + call mpas_pool_get_array(diag, 'w_100hPa', w_100hPa) call mpas_pool_get_array(diag, 'w_200hPa', w_200hPa) call mpas_pool_get_array(diag, 'w_250hPa', w_250hPa) call mpas_pool_get_array(diag, 'w_500hPa', w_500hPa) @@ -460,6 +538,8 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) call mpas_pool_get_array(diag, 'w_850hPa', w_850hPa) call mpas_pool_get_array(diag, 'w_925hPa', w_925hPa) + call mpas_pool_get_array(diag, 'vorticity_50hPa', vorticity_50hPa) + call mpas_pool_get_array(diag, 'vorticity_100hPa', vorticity_100hPa) call mpas_pool_get_array(diag, 'vorticity_200hPa', vorticity_200hPa) call mpas_pool_get_array(diag, 'vorticity_250hPa', vorticity_250hPa) call mpas_pool_get_array(diag, 'vorticity_500hPa', vorticity_500hPa) @@ -528,7 +608,10 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) do iCell = 1, nCells w1 = (height(k,iCell)-height(k-1,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) w2 = (height(k+1,iCell)-height(k,iCell)) / (height(k+1,iCell)-height(k-1,iCell)) - pressure2(k,iCell) = w1*pressure(k,iCell) + w2*pressure(k-1,iCell) + ! pressure2(k,iCell) = w1*pressure(k,iCell) + w2*pressure(k-1,iCell) + ! + ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 + pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k-1,iCell))) enddo enddo k = 1 @@ -538,7 +621,10 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) z2 = 0.5*(height(k+1,iCell)+height(k+2,iCell)) w1 = (z0-z2)/(z1-z2) w2 = 1.-w1 - pressure2(k,iCell) = w1*pressure(k,iCell)+w2*pressure(k+1,iCell) + ! pressure2(k,iCell) = w1*pressure(k,iCell)+w2*pressure(k+1,iCell) + ! + ! switch to use ln(pressure) for more accurate vertical interpolation, WCS 20230407 + pressure2(k,iCell) = exp(w1*log(pressure(k,iCell))+w2*log(pressure(k+1,iCell))) enddo !calculation of total pressure at cell vertices (at mass points): @@ -572,16 +658,18 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) end if !interpolation to fixed pressure levels for fields located at cells centers and at mass points: - nIntP = 6 + nIntP = 8 if(.not.allocated(field_interp)) allocate(field_interp(nCells,nIntP) ) if(.not.allocated(press_interp)) allocate(press_interp(nCells,nIntP) ) do iCell = 1, nCells - press_interp(iCell,1) = 200.0_RKIND - press_interp(iCell,2) = 250.0_RKIND - press_interp(iCell,3) = 500.0_RKIND - press_interp(iCell,4) = 700.0_RKIND - press_interp(iCell,5) = 850.0_RKIND - press_interp(iCell,6) = 925.0_RKIND + press_interp(iCell,1) = 50.0_RKIND + press_interp(iCell,2) = 100.0_RKIND + press_interp(iCell,3) = 200.0_RKIND + press_interp(iCell,4) = 250.0_RKIND + press_interp(iCell,5) = 500.0_RKIND + press_interp(iCell,6) = 700.0_RKIND + press_interp(iCell,7) = 850.0_RKIND + press_interp(iCell,8) = 925.0_RKIND enddo if(.not.allocated(press_in)) allocate(press_in(nCells,nVertLevels)) @@ -603,12 +691,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - temperature_200hPa(1:nCells) = field_interp(1:nCells,1) - temperature_250hPa(1:nCells) = field_interp(1:nCells,2) - temperature_500hPa(1:nCells) = field_interp(1:nCells,3) - temperature_700hPa(1:nCells) = field_interp(1:nCells,4) - temperature_850hPa(1:nCells) = field_interp(1:nCells,5) - temperature_925hPa(1:nCells) = field_interp(1:nCells,6) + temperature_50hPa(1:nCells) = field_interp(1:nCells,1) + temperature_100hPa(1:nCells) = field_interp(1:nCells,2) + temperature_200hPa(1:nCells) = field_interp(1:nCells,3) + temperature_250hPa(1:nCells) = field_interp(1:nCells,4) + temperature_500hPa(1:nCells) = field_interp(1:nCells,5) + temperature_700hPa(1:nCells) = field_interp(1:nCells,6) + temperature_850hPa(1:nCells) = field_interp(1:nCells,7) + temperature_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate temperature:') end if @@ -622,12 +712,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - relhum_200hPa(1:nCells) = field_interp(1:nCells,1) - relhum_250hPa(1:nCells) = field_interp(1:nCells,2) - relhum_500hPa(1:nCells) = field_interp(1:nCells,3) - relhum_700hPa(1:nCells) = field_interp(1:nCells,4) - relhum_850hPa(1:nCells) = field_interp(1:nCells,5) - relhum_925hPa(1:nCells) = field_interp(1:nCells,6) + relhum_50hPa(1:nCells) = field_interp(1:nCells,1) + relhum_100hPa(1:nCells) = field_interp(1:nCells,2) + relhum_200hPa(1:nCells) = field_interp(1:nCells,3) + relhum_250hPa(1:nCells) = field_interp(1:nCells,4) + relhum_500hPa(1:nCells) = field_interp(1:nCells,5) + relhum_700hPa(1:nCells) = field_interp(1:nCells,6) + relhum_850hPa(1:nCells) = field_interp(1:nCells,7) + relhum_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate relative humidity:') end if @@ -640,12 +732,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - dewpoint_200hPa(1:nCells) = field_interp(1:nCells,1) - dewpoint_250hPa(1:nCells) = field_interp(1:nCells,2) - dewpoint_500hPa(1:nCells) = field_interp(1:nCells,3) - dewpoint_700hPa(1:nCells) = field_interp(1:nCells,4) - dewpoint_850hPa(1:nCells) = field_interp(1:nCells,5) - dewpoint_925hPa(1:nCells) = field_interp(1:nCells,6) + dewpoint_50hPa(1:nCells) = field_interp(1:nCells,1) + dewpoint_100hPa(1:nCells) = field_interp(1:nCells,2) + dewpoint_200hPa(1:nCells) = field_interp(1:nCells,3) + dewpoint_250hPa(1:nCells) = field_interp(1:nCells,4) + dewpoint_500hPa(1:nCells) = field_interp(1:nCells,5) + dewpoint_700hPa(1:nCells) = field_interp(1:nCells,6) + dewpoint_850hPa(1:nCells) = field_interp(1:nCells,7) + dewpoint_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate relative humidity:') end if @@ -658,12 +752,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - uzonal_200hPa(1:nCells) = field_interp(1:nCells,1) - uzonal_250hPa(1:nCells) = field_interp(1:nCells,2) - uzonal_500hPa(1:nCells) = field_interp(1:nCells,3) - uzonal_700hPa(1:nCells) = field_interp(1:nCells,4) - uzonal_850hPa(1:nCells) = field_interp(1:nCells,5) - uzonal_925hPa(1:nCells) = field_interp(1:nCells,6) + uzonal_50hPa(1:nCells) = field_interp(1:nCells,1) + uzonal_100hPa(1:nCells) = field_interp(1:nCells,2) + uzonal_200hPa(1:nCells) = field_interp(1:nCells,3) + uzonal_250hPa(1:nCells) = field_interp(1:nCells,4) + uzonal_500hPa(1:nCells) = field_interp(1:nCells,5) + uzonal_700hPa(1:nCells) = field_interp(1:nCells,6) + uzonal_850hPa(1:nCells) = field_interp(1:nCells,7) + uzonal_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate zonal wind:') end if @@ -676,12 +772,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - umeridional_200hPa(1:nCells) = field_interp(1:nCells,1) - umeridional_250hPa(1:nCells) = field_interp(1:nCells,2) - umeridional_500hPa(1:nCells) = field_interp(1:nCells,3) - umeridional_700hPa(1:nCells) = field_interp(1:nCells,4) - umeridional_850hPa(1:nCells) = field_interp(1:nCells,5) - umeridional_925hPa(1:nCells) = field_interp(1:nCells,6) + umeridional_50hPa(1:nCells) = field_interp(1:nCells,1) + umeridional_100hPa(1:nCells) = field_interp(1:nCells,2) + umeridional_200hPa(1:nCells) = field_interp(1:nCells,3) + umeridional_250hPa(1:nCells) = field_interp(1:nCells,4) + umeridional_500hPa(1:nCells) = field_interp(1:nCells,5) + umeridional_700hPa(1:nCells) = field_interp(1:nCells,6) + umeridional_850hPa(1:nCells) = field_interp(1:nCells,7) + umeridional_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate meridional wind:') end if @@ -708,12 +806,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - height_200hPa(1:nCells) = field_interp(1:nCells,1) - height_250hPa(1:nCells) = field_interp(1:nCells,2) - height_500hPa(1:nCells) = field_interp(1:nCells,3) - height_700hPa(1:nCells) = field_interp(1:nCells,4) - height_850hPa(1:nCells) = field_interp(1:nCells,5) - height_925hPa(1:nCells) = field_interp(1:nCells,6) + height_50hPa(1:nCells) = field_interp(1:nCells,1) + height_100hPa(1:nCells) = field_interp(1:nCells,2) + height_200hPa(1:nCells) = field_interp(1:nCells,3) + height_250hPa(1:nCells) = field_interp(1:nCells,4) + height_500hPa(1:nCells) = field_interp(1:nCells,5) + height_700hPa(1:nCells) = field_interp(1:nCells,6) + height_850hPa(1:nCells) = field_interp(1:nCells,7) + height_925hPa(1:nCells) = field_interp(1:nCells,8) ! call mpas_log_write('--- end interpolate height:') !... vertical velocity @@ -724,12 +824,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nCells,nVertLevelsP1,nIntP,press_in,field_in,press_interp,field_interp) - w_200hPa(1:nCells) = field_interp(1:nCells,1) - w_250hPa(1:nCells) = field_interp(1:nCells,2) - w_500hPa(1:nCells) = field_interp(1:nCells,3) - w_700hPa(1:nCells) = field_interp(1:nCells,4) - w_850hPa(1:nCells) = field_interp(1:nCells,5) - w_925hPa(1:nCells) = field_interp(1:nCells,6) + w_50hPa(1:nCells) = field_interp(1:nCells,1) + w_100hPa(1:nCells) = field_interp(1:nCells,2) + w_200hPa(1:nCells) = field_interp(1:nCells,3) + w_250hPa(1:nCells) = field_interp(1:nCells,4) + w_500hPa(1:nCells) = field_interp(1:nCells,5) + w_700hPa(1:nCells) = field_interp(1:nCells,6) + w_850hPa(1:nCells) = field_interp(1:nCells,7) + w_925hPa(1:nCells) = field_interp(1:nCells,8) if(allocated(field_in)) deallocate(field_in) if(allocated(press_in)) deallocate(press_in) @@ -741,16 +843,18 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) if (NEED_VORTICITY) then !interpolation to fixed pressure levels for fields located at cell vertices and at mass points: - nIntP = 6 + nIntP = 8 if(.not.allocated(field_interp)) allocate(field_interp(nVertices,nIntP) ) if(.not.allocated(press_interp)) allocate(press_interp(nVertices,nIntP) ) do iVert = 1, nVertices - press_interp(iVert,1) = 200.0_RKIND - press_interp(iVert,2) = 250.0_RKIND - press_interp(iVert,3) = 500.0_RKIND - press_interp(iVert,4) = 700.0_RKIND - press_interp(iVert,5) = 850.0_RKIND - press_interp(iVert,6) = 925.0_RKIND + press_interp(iVert,1) = 50.0_RKIND + press_interp(iVert,2) = 100.0_RKIND + press_interp(iVert,3) = 200.0_RKIND + press_interp(iVert,4) = 250.0_RKIND + press_interp(iVert,5) = 500.0_RKIND + press_interp(iVert,6) = 700.0_RKIND + press_interp(iVert,7) = 850.0_RKIND + press_interp(iVert,8) = 925.0_RKIND enddo if(.not.allocated(press_in)) allocate(press_in(nVertices,nVertLevels)) @@ -770,12 +874,14 @@ subroutine interp_diagnostics(mesh, state, time_lev, diag) enddo enddo call interp_tofixed_pressure(nVertices,nVertLevels,nIntP,press_in,field_in,press_interp,field_interp) - vorticity_200hPa(1:nVertices) = field_interp(1:nVertices,1) - vorticity_250hPa(1:nVertices) = field_interp(1:nVertices,2) - vorticity_500hPa(1:nVertices) = field_interp(1:nVertices,3) - vorticity_700hPa(1:nVertices) = field_interp(1:nVertices,4) - vorticity_850hPa(1:nVertices) = field_interp(1:nVertices,5) - vorticity_925hPa(1:nVertices) = field_interp(1:nVertices,6) + vorticity_50hPa(1:nVertices) = field_interp(1:nVertices,1) + vorticity_100hPa(1:nVertices) = field_interp(1:nVertices,2) + vorticity_200hPa(1:nVertices) = field_interp(1:nVertices,3) + vorticity_250hPa(1:nVertices) = field_interp(1:nVertices,4) + vorticity_500hPa(1:nVertices) = field_interp(1:nVertices,5) + vorticity_700hPa(1:nVertices) = field_interp(1:nVertices,6) + vorticity_850hPa(1:nVertices) = field_interp(1:nVertices,7) + vorticity_925hPa(1:nVertices) = field_interp(1:nVertices,8) ! call mpas_log_write('--- end interpolate relative vorticity:') if(allocated(field_interp)) deallocate(field_interp) @@ -1244,4 +1350,4 @@ subroutine compute_layer_mean(layerMean, p1, p2, field_in, press_in) end subroutine compute_layer_mean -end module isobaric_diagnostics +end module mpas_isobaric_diagnostics diff --git a/src/core_atmosphere/diagnostics/pv_diagnostics.F b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F similarity index 94% rename from src/core_atmosphere/diagnostics/pv_diagnostics.F rename to src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F index da3d8fa605..d21061b0fb 100644 --- a/src/core_atmosphere/diagnostics/pv_diagnostics.F +++ b/src/core_atmosphere/diagnostics/mpas_pv_diagnostics.F @@ -5,7 +5,7 @@ ! 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 pv_diagnostics +module mpas_pv_diagnostics use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type use mpas_kind_types, only : RKIND @@ -13,8 +13,10 @@ module pv_diagnostics type (MPAS_pool_type), pointer :: mesh type (MPAS_pool_type), pointer :: state type (MPAS_pool_type), pointer :: diag +#ifdef DO_PHYSICS type (MPAS_pool_type), pointer :: tend type (MPAS_pool_type), pointer :: tend_physics +#endif type (MPAS_clock_type), pointer :: clock @@ -57,8 +59,10 @@ subroutine pv_diagnostics_setup(all_pools, simulation_clock) call mpas_pool_get_subpool(all_pools, 'mesh', mesh) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(all_pools, 'tend', tend) call mpas_pool_get_subpool(all_pools, 'tend_physics', tend_physics) +#endif clock => simulation_clock @@ -100,6 +104,7 @@ subroutine pv_diagnostics_compute() need_iLev_DT = MPAS_field_will_be_written('iLev_DT') need_any_diags = need_any_diags .or. need_iLev_DT +#ifdef DO_PHYSICS need_tend_lw = MPAS_field_will_be_written('depv_dt_lw') need_any_diags = need_any_diags .or. need_tend_lw need_any_budget = need_any_budget .or. need_tend_lw @@ -133,13 +138,16 @@ subroutine pv_diagnostics_compute() need_tend_fric_pv = MPAS_field_will_be_written('depv_dt_fric_pv') need_any_diags = need_any_diags .or. need_tend_fric_pv need_any_budget = need_any_budget .or. need_tend_fric_pv +#endif if (need_any_diags) then call atm_compute_pv_diagnostics(state, 1, diag, mesh) end if +#ifdef DO_PHYSICS if (need_any_budget) then call atm_compute_pvBudget_diagnostics(state, 1, diag, mesh, tend, tend_physics) end if +#endif end subroutine pv_diagnostics_compute @@ -591,29 +599,41 @@ subroutine floodFill_tropo(mesh, diag, pvuVal) ! (2) flood fill troposphere (<2pvu) from troposphere seeds near surface. !Somewhat paradoxically, the bottom of the stratosphere is lower than the top of the troposphere. + !Originally, it was assumed that each (MPI) domain would have >0 cells with "right" DT found by flood filling. + !However, for "small" domains over the Arctic say during winter, the entire surface can be capped by high PV. + !So, we need to communicate between domains during the flood fill or else we find the DT at the surface. + !The extreme limiting case is if we had every cell as its own domain; then, it's clear that there has to be communication. + !The "output" is iLev_DT, which is the vertical index for the level >= pvuVal. If >nVertLevels, pvuVal above column. If <2, pvuVal below column. !Communication between blocks during the flood fill may be needed to treat some edge cases appropriately. - use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array + use mpas_pool_routines, only : mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_field + use mpas_dmpar, only : mpas_dmpar_max_int,mpas_dmpar_exch_halo_field + use mpas_derived_types, only : dm_info, field2DInteger implicit none type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(inout) :: diag real(kind=RKIND), intent(in) :: pvuVal - - integer :: iCell, k, nChanged, iNbr, iCellNbr, levInd - integer, pointer :: nCells, nVertLevels + + integer :: iCell, k, nChanged, iNbr, iCellNbr, levInd, haloChanged, global_haloChanged + integer, pointer :: nCells, nVertLevels, nCellsSolve integer, dimension(:), pointer :: nEdgesOnCell, iLev_DT - integer, dimension(:,:), pointer :: cellsOnCell - + integer, dimension(:,:), pointer :: cellsOnCell, inTropo + + type (field2DInteger), pointer :: inTropo_f + real(kind=RKIND) :: sgnHemi, sgn real(kind=RKIND),dimension(:),pointer:: latCell real(kind=RKIND), dimension(:,:), pointer :: ertel_pv - integer, dimension(:,:), allocatable :: candInTropo, inTropo !whether in troposphere + type (dm_info), pointer :: dminfo + + integer, dimension(:,:), allocatable :: candInTropo !whether in troposphere call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) @@ -622,9 +642,9 @@ subroutine floodFill_tropo(mesh, diag, pvuVal) call mpas_pool_get_array(diag, 'ertel_pv', ertel_pv) !call mpas_pool_get_array(diag, 'iLev_DT_trop', iLev_DT) call mpas_pool_get_array(diag, 'iLev_DT', iLev_DT) + call mpas_pool_get_array(diag, 'inTropo', inTropo) allocate(candInTropo(nVertLevels, nCells+1)) - allocate(inTropo(nVertLevels, nCells+1)) candInTropo(:,:) = 0 inTropo(:,:) = 0 !store whether each level above DT to avoid repeating logic. we'll use cand as a isVisited marker further below. @@ -645,7 +665,7 @@ subroutine floodFill_tropo(mesh, diag, pvuVal) do k=1,levInd if (candInTropo(k,iCell) .GT. 0) then inTropo(k,iCell) = 1 - candInTropo(k,iCell) = 0 + !candInTropo(k,iCell) = 0 nChanged = nChanged+1 end if end do @@ -653,48 +673,63 @@ subroutine floodFill_tropo(mesh, diag, pvuVal) !flood fill from the given seeds. since I don't know enough fortran, !we'll just brute force a continuing loop rather than queue. - do while(nChanged .GT. 0) - nChanged = 0 - do iCell=1,nCells - do k=1,nVertLevels - !update if candidate and neighbor in troposphere - if (candInTropo(k,iCell) .GT. 0) then - !nbr below - if (k .GT. 1) then - if (inTropo(k-1,iCell) .GT. 0) then - inTropo(k,iCell) = 1 - candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - cycle - end if - end if - - !side nbrs - do iNbr = 1, nEdgesOnCell(iCell) - iCellNbr = cellsOnCell(iNbr,iCell) - if (inTropo(k,iCellNbr) .GT. 0) then - inTropo(k,iCell) = 1 - candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - cycle + call mpas_pool_get_field(diag, 'inTropo', inTropo_f) + dminfo => inTropo_f % block % domain % dminfo + global_haloChanged = 1 + do while(global_haloChanged .GT. 0) !any cell in a halo has changed, to propagate to other domains + global_haloChanged = 0 !aggregate the number of changed cells w/in the loop below + do while(nChanged .GT. 0) + nChanged = 0 + do iCell=1,nCells !should we look for neighbors of hallo cells? + !do iCell=1,nCellsSolve !should we look for neighbors of hallo cells? + do k=1,nVertLevels + !update if candidate and neighbor in troposphere + if ((candInTropo(k,iCell) .GT. 0) .AND. (inTropo(k,iCell).LT.1) ) then + !nbr below + if (k .GT. 1) then + if (inTropo(k-1,iCell) .GT. 0) then + inTropo(k,iCell) = 1 + !candInTropo(k,iCell) = 0 + nChanged = nChanged+1 + cycle + end if end if - end do - - !nbr above - if (k .LT. nVertLevels) then - if (inTropo(k+1,iCell) .GT. 0) then - inTropo(k,iCell) = 1 - candInTropo(k,iCell) = 0 - nChanged = nChanged+1 - cycle + + !side nbrs + do iNbr = 1, nEdgesOnCell(iCell) + iCellNbr = cellsOnCell(iNbr,iCell) + if (inTropo(k,iCellNbr) .GT. 0) then + inTropo(k,iCell) = 1 + !candInTropo(k,iCell) = 0 + nChanged = nChanged+1 + exit + end if + end do + + !nbr above + if (k .LT. nVertLevels) then + if (inTropo(k+1,iCell) .GT. 0) then + inTropo(k,iCell) = 1 + !candInTropo(k,iCell) = 0 + nChanged = nChanged+1 + cycle + end if end if - end if - - end if !candIn - end do !levels - end do !cells - !here's where a communication would be needed for edge cases !!! - end do !while + + end if !candIn + end do !levels + end do !cells + global_haloChanged = global_haloChanged+nChanged + end do !while w/in domain + !communicate to other domains for edge case where a chunk of a block hasn't gotten to fill + nChanged = global_haloChanged + call mpas_dmpar_max_int(dminfo, nChanged, global_haloChanged) + if (global_haloChanged .GT. 0) then !communicate inTropo everywhere + call mpas_dmpar_exch_halo_field(inTropo_f) + end if + nChanged = global_haloChanged !so each block will iterate again if anything changed + end do !while haloChanged + deallocate(candInTropo) !Fill iLev_DT with the lowest level above the tropopause (If DT above column, iLev>nVertLevels. If DT below column, iLev=0. do iCell=1,nCells @@ -1457,7 +1492,7 @@ subroutine calc_pvBudget(state, time_lev, diag, mesh, tend, tend_physics) depv_dt_mp(k,iCell) = 0.0_RKIND end if - if (associated(dtheta_dt_mp)) then + if (associated(dtheta_dt_mix)) then call calc_grad_cell(gradtheta, & iCell, k, nVertLevels, nEdgesOnCell(iCell), verticesOnCell, kiteAreasOnVertex, & cellsOnCell, edgesOnCell, cellsOnEdge, dvEdge, edgeNormalVectors, & @@ -1612,4 +1647,4 @@ subroutine atm_compute_pvBudget_diagnostics(state, time_lev, diag, mesh, tend, t end subroutine atm_compute_pvBudget_diagnostics -end module pv_diagnostics +end module mpas_pv_diagnostics diff --git a/src/core_atmosphere/diagnostics/soundings.F b/src/core_atmosphere/diagnostics/mpas_soundings.F similarity index 88% rename from src/core_atmosphere/diagnostics/soundings.F rename to src/core_atmosphere/diagnostics/mpas_soundings.F index c213f6f82b..3175dfad1a 100644 --- a/src/core_atmosphere/diagnostics/soundings.F +++ b/src/core_atmosphere/diagnostics/mpas_soundings.F @@ -5,7 +5,7 @@ ! 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 soundings +module mpas_soundings use mpas_kind_types, only : RKIND, StrKIND use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type @@ -50,11 +50,12 @@ module soundings !----------------------------------------------------------------------- subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) - use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, dm_info - use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config + use mpas_derived_types, only : MPAS_pool_type, MPAS_clock_type, dm_info, MPAS_POOL_SILENT + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_dimension, mpas_pool_get_array, mpas_pool_get_config, & + mpas_pool_get_error_level, mpas_pool_set_error_level use mpas_io_units, only : mpas_new_unit, mpas_release_unit - use mpas_timekeeping, only : MPAS_timeInterval_type, MPAS_time_type, MPAS_set_timeInterval, & - MPAS_get_clock_time, MPAS_add_clock_alarm, MPAS_NOW + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_timekeeping, only : MPAS_set_timeInterval, MPAS_get_clock_time, MPAS_add_clock_alarm use mpas_dmpar, only : IO_NODE, mpas_dmpar_bcast_int, mpas_dmpar_bcast_logical, mpas_dmpar_bcast_char implicit none @@ -67,6 +68,7 @@ subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) character(len=StrKIND), pointer :: soundingInterval integer :: i, ierr + integer :: err_level integer :: sndUnit real (kind=RKIND) :: station_lat, station_lon character (len=StrKIND) :: tempstr @@ -87,8 +89,30 @@ subroutine soundings_setup(configs, all_pools, simulation_clock, dminfo) call mpas_pool_get_subpool(all_pools, 'state', state) call mpas_pool_get_subpool(all_pools, 'diag', diag) + ! + ! Query the config_sounding_interval namelist option without triggering + ! warning messages if no such option exists + ! + nullify(soundingInterval) + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) call mpas_pool_get_config(configs, 'config_sounding_interval', soundingInterval) + call mpas_pool_set_error_level(err_level) + + ! + ! If the config_sounding_interval namelist option was not found, just return + ! This may happen if MPAS-A is built within another system where, e.g., only + ! dynamics namelist options are available + ! + if (.not. associated(soundingInterval)) then + call mpas_log_write('config_sounding_interval is not a namelist option...') + return + end if + ! + ! If the config_sounding_interval namelist option is 'none', no soundings + ! will to be produced + ! if (trim(soundingInterval) == 'none') then return end if @@ -205,9 +229,10 @@ subroutine soundings_compute() use mpas_derived_types, only : MPAS_pool_type use mpas_pool_routines, only : MPAS_pool_get_dimension, MPAS_pool_get_array - use mpas_timekeeping, only : MPAS_time_type, MPAS_is_alarm_ringing, MPAS_reset_clock_alarm, MPAS_get_clock_time, & - MPAS_get_time, MPAS_NOW + use mpas_derived_types, only : MPAS_Time_type, MPAS_NOW + use mpas_timekeeping, only : MPAS_is_alarm_ringing, MPAS_reset_clock_alarm, MPAS_get_clock_time, MPAS_get_time use mpas_constants, only : rvord + use mpas_io_units, only: mpas_new_unit, mpas_release_unit implicit none @@ -220,6 +245,7 @@ subroutine soundings_compute() type (MPAS_time_type) :: now character(len=StrKIND) :: nowString integer :: yyyy, mm, dd, h, m, s + integer :: sndUnit character(len=StrKIND) :: fname character(len=10) :: stid @@ -247,16 +273,17 @@ subroutine soundings_compute() ! call mpas_log_write('Writing sounding for station '//trim(stationNames(iStn))) write(fname,'(a,i4.4,i2.2,i2.2,i2.2,i2.2,a)') trim(stationNames(iStn))//'.', yyyy, mm, dd, h, m, '.snd' - open(97,file=trim(fname),form='formatted',status='replace') + call mpas_new_unit(sndUnit) + open(sndUnit,file=trim(fname),form='formatted',status='replace') write(stid,'(a)') trim(stationNames(iStn)) - write(97,'(a)') ' SNPARM = PRES;HGHT;TMPC;DWPC;DRCT;SPED;' - write(97,'(a)') '' - write(97,'(a,i2.2,i2.2,i2.2,a,i2.2,i2.2)') ' STID = '//stid//' STNM = 99999 TIME = ', mod(yyyy,100), mm, dd,'/', h, m - write(97,'(a,f6.2,a,f7.2,a)') ' SLAT = ', stationLats(iStn), ' SLON = ', stationLons(iStn), ' SELV = -999' - write(97,'(a)') '' - write(97,'(a)') ' PRES HGHT TMPC DWPC DRCT SPED' + write(sndUnit,'(a)') ' SNPARM = PRES;HGHT;TMPC;DWPC;DRCT;SPED;' + write(sndUnit,'(a)') '' + write(sndUnit,'(a,i2.2,i2.2,i2.2,a,i2.2,i2.2)') ' STID = '//stid//' STNM = 99999 TIME = ', mod(yyyy,100), mm, dd,'/', h, m + write(sndUnit,'(a,f6.2,a,f7.2,a)') ' SLAT = ', stationLats(iStn), ' SLON = ', stationLons(iStn), ' SELV = -999' + write(sndUnit,'(a)') '' + write(sndUnit,'(a)') ' PRES HGHT TMPC DWPC DRCT SPED' do k=1,nVertLevels tmpc = theta_m(k,stationCells(iStn)) / (1.0_RKIND + rvord * scalars(index_qv,k,stationCells(iStn))) * exner(k,stationCells(iStn)) @@ -281,7 +308,7 @@ subroutine soundings_compute() end if dir = dir * 180.0_RKIND / pi_const end if - write(97,'(f10.2,f10.2,f9.2,f9.2,f9.2,f9.2)') & + write(sndUnit,'(f10.2,f10.2,f9.2,f9.2,f9.2,f9.2)') & pres, & 0.5 * (zgrid(k,stationCells(iStn)) + zgrid(k+1,stationCells(iStn))), & ! Avg to layer midpoint tmpc, & @@ -290,7 +317,8 @@ subroutine soundings_compute() spd end do - close(97) + close(sndUnit) + call mpas_release_unit(sndUnit) end if end do @@ -463,4 +491,4 @@ REAL(KIND=RKIND) FUNCTION RSIF(P,T) END FUNCTION RSIF -end module soundings +end module mpas_soundings diff --git a/src/core_atmosphere/dynamics/Makefile b/src/core_atmosphere/dynamics/Makefile index 97785deb4e..6892633c68 100644 --- a/src/core_atmosphere/dynamics/Makefile +++ b/src/core_atmosphere/dynamics/Makefile @@ -1,10 +1,14 @@ .SUFFIXES: .F .o -OBJS = mpas_atm_time_integration.o +OBJS = mpas_atm_time_integration.o \ + mpas_atm_boundaries.o all: $(OBJS) -mpas_atm_time_integration.o: mpas_atm_iau.o +mpas_atm_time_integration.o: mpas_atm_boundaries.o mpas_atm_iau.o + +mpas_atm_boundaries.o: + clean: $(RM) *.o *.mod *.f90 @@ -16,7 +20,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../physics/physics_mmm -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/dynamics/mpas_atm_boundaries.F b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F new file mode 100644 index 0000000000..7d439b49a8 --- /dev/null +++ b/src/core_atmosphere/dynamics/mpas_atm_boundaries.F @@ -0,0 +1,651 @@ +! Copyright (c) 2016, Los Alamos National Security, LLC (LANS) +! and 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_boundaries + + use mpas_derived_types, only : mpas_pool_type, mpas_clock_type, block_type, mpas_time_type, mpas_timeInterval_type, MPAS_NOW, & + MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & + MPAS_streamManager_type + use mpas_pool_routines, only : mpas_pool_get_array, mpas_pool_get_dimension, mpas_pool_get_subpool, mpas_pool_shift_time_levels + use mpas_kind_types, only : RKIND, StrKIND + use mpas_timekeeping, only : mpas_get_clock_time, mpas_get_timeInterval, mpas_set_time, operator(-) +#ifdef __NVCOMPILER + ! + ! Some versions of the nvfortran compiler complain about the illegal use + ! of an operator on a derived type if the following specific + ! implementation of the (-) operator is not explicitly imported + ! + use mpas_timekeeping, only : sub_t_t +#endif + + ! Important note: At present, the code in mpas_atm_setup_bdy_masks for + ! deriving the nearestRelaxationCell field assumes that nSpecZone == 2 + integer, parameter :: nSpecZone = 2 + integer, parameter :: nRelaxZone = 5 + integer, parameter :: nBdyZone = nSpecZone + nRelaxZone + + public :: mpas_atm_update_bdy_tend, & + mpas_atm_get_bdy_tend, & + mpas_atm_get_bdy_state, & + mpas_atm_setup_bdy_masks, & + mpas_atm_bdy_checks + + public :: nBdyZone, nSpecZone, nRelaxZone + + private + + type (MPAS_Time_Type) :: LBC_intv_end + + + contains + + + !*********************************************************************** + ! + ! routine mpas_atm_update_bdy_tend + ! + !> \brief Reads new boundary data and updates the LBC tendencies + !> \author Michael Duda + !> \date 27 September 2016 + !> \details + !> This routine reads from the 'lbc_in' stream all variables in the 'lbc' + !> pool. When called with firstCall=.true., the latest time before the + !> present is read into time level 2 of the lbc pool; otherwise, the + !> contents of time level 2 are shifted to time level 1, the earliest + !> time strictly later than the present is read into time level 2, and + !> the tendencies for all fields in the lbc pool are computed and stored + !> in time level 1. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_update_bdy_tend(clock, streamManager, block, firstCall, ierr) + + use mpas_constants, only : rvord + use mpas_stream_manager, only : mpas_stream_mgr_read + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR, MPAS_LOG_ERR + use mpas_timekeeping, only : mpas_get_time + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (MPAS_streamManager_type), intent(inout) :: streamManager + type (block_type), intent(inout) :: block + logical, intent(in) :: firstCall + integer, intent(out) :: ierr + + character(len=StrKIND) :: lbc_intv_start_string + character(len=StrKIND) :: lbc_intv_end_string + + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: lbc + real (kind=RKIND) :: dt + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: index_qv + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rho_edge + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rtheta_m + real (kind=RKIND), dimension(:,:), pointer :: rho_zz + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_u + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_ru + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_edge + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_w + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_theta + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rtheta_m + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho_zz + real (kind=RKIND), dimension(:,:), pointer :: lbc_tend_rho + real (kind=RKIND), dimension(:,:,:), pointer :: lbc_tend_scalars + + integer, dimension(:,:), pointer :: cellsOnEdge + real (kind=RKIND), dimension(:,:), pointer :: zz + + integer :: dd_intv, s_intv, sn_intv, sd_intv + type (MPAS_Time_Type) :: currTime + type (MPAS_TimeInterval_Type) :: lbc_interval + character(len=StrKIND) :: read_time + integer :: iEdge + integer :: cell1, cell2 + + + ierr = 0 + + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + if (firstCall) then + call MPAS_stream_mgr_read(streamManager, streamID='lbc_in', timeLevel=2, whence=MPAS_STREAM_LATEST_BEFORE, & + actualWhen=read_time, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''lbc_in'' stream on or before the current date '// & + 'to update lateral boundary tendencies', messageType=MPAS_LOG_ERR) + ierr = 1 + end if + else + call mpas_pool_shift_time_levels(lbc) + call MPAS_stream_mgr_read(streamManager, streamID='lbc_in', timeLevel=2, whence=MPAS_STREAM_EARLIEST_STRICTLY_AFTER, & + actualWhen=read_time, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Could not read from ''lbc_in'' stream after the current date '// & + 'to update lateral boundary tendencies', messageType=MPAS_LOG_ERR) + ierr = 1 + end if + end if + if (ierr /= 0) then + return + end if + + call mpas_set_time(currTime, dateTimeString=trim(read_time)) + + ! + ! Compute any derived fields from those that were read from the lbc_in stream + ! + call mpas_pool_get_array(lbc, 'lbc_u', u, 2) + call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) + call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_rho', rho, 2) + call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(lbc, 'index_qv', index_qv) + call mpas_pool_get_array(mesh, 'zz', zz) + + ! Compute lbc_rho_zz + zz(:,nCells+1) = 1.0_RKIND ! Avoid potential division by zero in the following line + rho_zz(:,:) = rho(:,:) / zz(:,:) + + ! Average lbc_rho_zz to edges + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + if (cell1 > 0 .and. cell2 > 0) then + rho_edge(:,iEdge) = 0.5_RKIND * (rho_zz(:,cell1) + rho_zz(:,cell2)) + end if + end do + + ru(:,:) = u(:,:) * rho_edge(:,:) + rtheta_m(:,:) = theta(:,:) * rho_zz(:,:) * (1.0_RKIND + rvord * scalars(index_qv,:,:)) + + if (.not. firstCall) then + lbc_interval = currTime - LBC_intv_end + call mpas_get_timeInterval(interval=lbc_interval, DD=dd_intv, S=s_intv, S_n=sn_intv, S_d=sd_intv, ierr=ierr) + dt = 86400.0_RKIND * real(dd_intv, kind=RKIND) + real(s_intv, kind=RKIND) & + + (real(sn_intv, kind=RKIND) / real(sd_intv, kind=RKIND)) + + call mpas_pool_get_array(lbc, 'lbc_u', u, 2) + call mpas_pool_get_array(lbc, 'lbc_ru', ru, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', rho_edge, 2) + call mpas_pool_get_array(lbc, 'lbc_w', w, 2) + call mpas_pool_get_array(lbc, 'lbc_theta', theta, 2) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', rtheta_m, 2) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', rho_zz, 2) + call mpas_pool_get_array(lbc, 'lbc_rho', rho, 2) + call mpas_pool_get_array(lbc, 'lbc_scalars', scalars, 2) + + call mpas_pool_get_array(lbc, 'lbc_u', lbc_tend_u, 1) + call mpas_pool_get_array(lbc, 'lbc_ru', lbc_tend_ru, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_edge', lbc_tend_rho_edge, 1) + call mpas_pool_get_array(lbc, 'lbc_w', lbc_tend_w, 1) + call mpas_pool_get_array(lbc, 'lbc_theta', lbc_tend_theta, 1) + call mpas_pool_get_array(lbc, 'lbc_rtheta_m', lbc_tend_rtheta_m, 1) + call mpas_pool_get_array(lbc, 'lbc_rho_zz', lbc_tend_rho_zz, 1) + call mpas_pool_get_array(lbc, 'lbc_rho', lbc_tend_rho, 1) + call mpas_pool_get_array(lbc, 'lbc_scalars', lbc_tend_scalars, 1) + + + dt = 1.0_RKIND / dt + lbc_tend_u(:,:) = (u(:,:) - lbc_tend_u(:,:)) * dt + lbc_tend_ru(:,:) = (ru(:,:) - lbc_tend_ru(:,:)) * dt + lbc_tend_rho_edge(:,:) = (rho_edge(:,:) - lbc_tend_rho_edge(:,:)) * dt + lbc_tend_w(:,:) = (w(:,:) - lbc_tend_w(:,:)) * dt + lbc_tend_theta(:,:) = (theta(:,:) - lbc_tend_theta(:,:)) * dt + lbc_tend_rtheta_m(:,:) = (rtheta_m(:,:) - lbc_tend_rtheta_m(:,:)) * dt + lbc_tend_rho_zz(:,:) = (rho_zz(:,:) - lbc_tend_rho_zz(:,:)) * dt + lbc_tend_rho(:,:) = (rho(:,:) - lbc_tend_rho(:,:)) * dt + lbc_tend_scalars(:,:,:) = (scalars(:,:,:) - lbc_tend_scalars(:,:,:)) * dt + + ! + ! Logging the lbc start and end times appears to be backwards, but + ! until the end of this function, LBC_intv_end == the last interval + ! time and currTime == the next interval time. + ! + call mpas_get_time(LBC_intv_end, dateTimeString=lbc_intv_start_string) + call mpas_get_time(currTime, dateTimeString=lbc_intv_end_string) + call mpas_log_write('----------------------------------------------------------------------') + call mpas_log_write('Updated lateral boundary conditions. LBCs are now valid') + call mpas_log_write('from '//trim(lbc_intv_start_string)//' to '//trim(lbc_intv_end_string)) + call mpas_log_write('----------------------------------------------------------------------') + + end if + + LBC_intv_end = currTime + + end subroutine mpas_atm_update_bdy_tend + + + !*********************************************************************** + ! + ! routine mpas_atm_get_bdy_tend + ! + !> \brief Returns LBC tendencies a specified delta-t in the future + !> \author Michael Duda + !> \date 28 September 2016 + !> \details + !> This function returns an array providing the tendency for the requested + !> progostic variable delta_t in the future from the current time known + !> by the simulation clock (which is typically the time at the start of + !> the current timestep). + !> + !> The vertDim and horizDim should match the nominal block dimensions of + !> the field to be returned by the call; for example, a call to retrieve + !> the tendency for the 'u' field would set vertDim=nVertLevels and + !> horizDim=nEdges. This function internally adds 1 to the horizontal + !> dimension to account for the "garbage" element. + !> + !> The field is identified by the 'field' argument, and this argument is + !> prefixed with 'lbc_' before attempting to retrieve the field from + !> the 'lbc' pool. For scalars, the field argument should give the name + !> of the constituent, e.g., 'qv'. + !> + !> Example calls to this function: + !> + !> tend_u(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND) + !> tend_w(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels+1, nCells, 'w', 0.0_RKIND) + !> tend_rho_zz(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND) + !> tend_theta(:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'theta', 0.0_RKIND) + !> tend_scalars(1,:,:) = mpas_atm_get_bdy_tend(clock, domain % blocklist, nVertLevels, nCells, 'qv', 0.0_RKIND) + ! + !----------------------------------------------------------------------- + function mpas_atm_get_bdy_tend(clock, block, vertDim, horizDim, field, delta_t) result(return_tend) + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (block_type), intent(inout) :: block + integer, intent(in) :: vertDim, horizDim + character(len=*), intent(in) :: field + real (kind=RKIND), intent(in) :: delta_t + + real (kind=RKIND), dimension(vertDim,horizDim+1) :: return_tend + + type (mpas_pool_type), pointer :: lbc + integer, pointer :: idx + real (kind=RKIND), dimension(:,:), pointer :: tend + real (kind=RKIND), dimension(:,:,:), pointer :: tend_scalars + integer :: ierr + + + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + nullify(tend) + call mpas_pool_get_array(lbc, 'lbc_'//trim(field), tend, 1) + + if (associated(tend)) then + return_tend(:,:) = tend(:,:) + else + call mpas_pool_get_array(lbc, 'lbc_scalars', tend_scalars, 1) + call mpas_pool_get_dimension(lbc, 'index_'//trim(field), idx) + + return_tend(:,:) = tend_scalars(idx,:,:) + end if + + end function mpas_atm_get_bdy_tend + + + !*********************************************************************** + ! + ! routine mpas_atm_get_bdy_state + ! + !> \brief Returns LBC state at a specified delta-t in the future + !> \author Michael Duda + !> \date 28 September 2016 + !> \details + !> This function returns an array providing the state for the requested + !> progostic variable delta_t in the future from the current time known + !> by the simulation clock (which is typically the time at the start of + !> the current timestep). + !> + !> The vertDim and horizDim should match the nominal block dimensions of + !> the field to be returned by the call; for example, a call to retrieve + !> the state of the 'u' field would set vertDim=nVertLevels and + !> horizDim=nEdges. This function internally adds 1 to the horizontal + !> dimension to account for the "garbage" element. + !> + !> The field is identified by the 'field' argument, and this argument is + !> prefixed with 'lbc_' before attempting to retrieve the field from + !> the 'lbc' pool. For scalars, the field argument should give the name + !> of the constituent, e.g., 'qv'. + !> + !> Example calls to this function: + !> + !> u(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nEdges, 'u', 0.0_RKIND) + !> w(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels+1, nCells, 'w', 0.0_RKIND) + !> rho_zz(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'rho_zz', 0.0_RKIND) + !> theta(:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'theta', 0.0_RKIND) + !> scalars(1,:,:) = mpas_atm_get_bdy_state(clock, domain % blocklist, nVertLevels, nCells, 'qv', 0.0_RKIND) + ! + !----------------------------------------------------------------------- + function mpas_atm_get_bdy_state(clock, block, vertDim, horizDim, field, delta_t) result(return_state) + + use mpas_pool_routines, only : mpas_pool_get_error_level, mpas_pool_set_error_level + use mpas_derived_types, only : MPAS_POOL_SILENT + + implicit none + + type (mpas_clock_type), intent(in) :: clock + type (block_type), intent(inout) :: block + integer, intent(in) :: vertDim, horizDim + character(len=*), intent(in) :: field + real (kind=RKIND), intent(in) :: delta_t + + real (kind=RKIND), dimension(vertDim,horizDim+1) :: return_state + + type (mpas_pool_type), pointer :: lbc + integer, pointer :: idx + real (kind=RKIND), dimension(:,:), pointer :: tend + real (kind=RKIND), dimension(:,:), pointer :: state + real (kind=RKIND), dimension(:,:,:), pointer :: tend_scalars + real (kind=RKIND), dimension(:,:,:), pointer :: state_scalars + type (MPAS_Time_Type) :: currTime + type (MPAS_TimeInterval_Type) :: lbc_interval + integer :: dd_intv, s_intv, sn_intv, sd_intv + real (kind=RKIND) :: dt + integer :: err_level + integer :: ierr + + + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + + lbc_interval = LBC_intv_end - currTime + + call mpas_get_timeInterval(interval=lbc_interval, DD=dd_intv, S=s_intv, S_n=sn_intv, S_d=sd_intv, ierr=ierr) + dt = 86400.0_RKIND * real(dd_intv, kind=RKIND) + real(s_intv, kind=RKIND) & + + (real(sn_intv, kind=RKIND) / real(sd_intv, kind=RKIND)) + + dt = dt - delta_t + + call mpas_pool_get_subpool(block % structs, 'lbc', lbc) + + ! + ! The first two calls to mpas_pool_get_array, below, may cause harmless warning + ! messages, which we can silence by setting the pool error level + ! + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + nullify(tend) + nullify(state) + + call mpas_pool_get_array(lbc, 'lbc_'//trim(field), tend, 1) + call mpas_pool_get_array(lbc, 'lbc_'//trim(field), state, 2) + + ! Reset the pool error level to its previous value + call mpas_pool_set_error_level(err_level) + + ! + ! If we have both a tendency and state for this boundary field from the tend and state + ! pools, then the requested field was not a scalar constituent; otherwise, we need to + ! query the field as a scalar constituent + ! + if (associated(tend) .and. associated(state)) then + return_state(:,:) = state(:,:) - dt * tend(:,:) + else + call mpas_pool_get_array(lbc, 'lbc_scalars', tend_scalars, 1) + call mpas_pool_get_array(lbc, 'lbc_scalars', state_scalars, 2) + call mpas_pool_get_dimension(lbc, 'index_'//trim(field), idx) + + return_state(:,:) = state_scalars(idx,:,:) - dt * tend_scalars(idx,:,:) + end if + + end function mpas_atm_get_bdy_state + + + !*********************************************************************** + ! + ! routine mpas_atm_setup_bdy_masks + ! + !> \brief Prepares various fields for boundaries of limited-area + !> \author Michael Duda + !> \date 28 September 2016 + !> \details + !> This routine prepares (1) the mask field needed to distinguish cells in + !> the specified zone from those in the relaxation zone, and (2) a field + !> of indices identifying the closest relaxation cell to each cell in + !> the specified zone.. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_setup_bdy_masks(mesh, configs) + + implicit none + + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: configs + + integer :: iCell, i, j, ii, jj + real (kind=RKIND) :: d, dmin + + integer, pointer :: nCells + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge, bdyMaskVertex + integer, dimension(:), pointer :: nearestRelaxationCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell, specZoneMaskEdge, specZoneMaskVertex + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + call mpas_pool_get_array(mesh, 'bdyMaskVertex', bdyMaskVertex) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) + call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) + call mpas_pool_get_array(mesh, 'specZoneMaskVertex', specZoneMaskVertex) + call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + + ! + ! Setup mask identifying cells/edges/vertices in the specified zone + ! NB: The specZoneMask{Cell,Edge,Vertex} fields receive a default value of 0.0 from the Registry, + ! so no need to initialize them here + ! + where (bdyMaskCell(:) > nRelaxZone) specZoneMaskCell(:) = 1.0_RKIND + where (bdyMaskEdge(:) > nRelaxZone) specZoneMaskEdge(:) = 1.0_RKIND + where (bdyMaskVertex(:) > nRelaxZone) specZoneMaskVertex(:) = 1.0_RKIND + + + nearestRelaxationCell(:) = nCells+1 + + ! + ! For nearest relaxation cell to inner specified zone, just search + ! all cellsOnCell with bdyMaskCell == nRelaxZone + ! + do iCell=1,nCells + if (bdyMaskCell(iCell) == (nRelaxZone+1)) then + dmin = 1.0e36 + do j=1,nEdgesOnCell(iCell) + i = cellsOnCell(j,iCell) + if (bdyMaskCell(i) == nRelaxZone) then + d = (xCell(i) - xCell(iCell))**2 + (yCell(i) - yCell(iCell))**2 + (zCell(i) - zCell(iCell))**2 + if (d < dmin) then + dmin = d + nearestRelaxationCell(iCell) = i + end if + end if + end do + end if + end do + + ! + ! For nearest relaxation cell to outer specified zone, search + ! all cellsOnCell of cellsOnCell + ! + do iCell=1,nCells + if (bdyMaskCell(iCell) == (nRelaxZone+2)) then + dmin = 1.0e36 + do j=1,nEdgesOnCell(iCell) + i = cellsOnCell(j,iCell) + if (bdyMaskCell(i) == (nRelaxZone+1)) then + + do jj=1,nEdgesOnCell(i) + ii = cellsOnCell(jj,i) + if (bdyMaskCell(ii) == nRelaxZone) then + + d = (xCell(ii) - xCell(iCell))**2 + (yCell(ii) - yCell(iCell))**2 + (zCell(ii) - zCell(iCell))**2 + if (d < dmin) then + dmin = d + nearestRelaxationCell(iCell) = ii + end if + + end if + end do + + end if + end do + end if + end do + + end subroutine mpas_atm_setup_bdy_masks + + + !*********************************************************************** + ! + ! routine mpas_atm_bdy_checks + ! + !> \brief Checks compatibility of limited-area settings + !> \author Michael Duda + !> \date 12 May 2019 + !> \details + !> This routine checks that settings related to limited-area simulations + !> are compatible. Specifically, the following are checked by this routine: + !> + !> 1) If config_apply_lbcs = true, the bdyMaskCell field must have non-zero elements + !> 2) If config_apply_lbcs = false, the bdyMaskCell field must not have non-zero elements + !> 3) If config_apply_lbcs = true, the lbc_in stream must have a valid input interval + !> + !> If any of the above are not true, this routine prints an error message and + !> returns a non-zero value in ierr; otherwise, a value of 0 is returned. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_bdy_checks(dminfo, blockList, streamManager, ierr) + + use mpas_log, only : mpas_log_write + use mpas_kind_types, only : StrKIND + use mpas_derived_types, only : dm_info, block_type, mpas_pool_type, MPAS_LOG_ERR, MPAS_STREAM_PROPERTY_RECORD_INTV, & + MPAS_STREAM_MGR_NOERR, MPAS_STREAM_INPUT + use mpas_stream_manager, only : mpas_stream_mgr_get_property + use mpas_pool_routines, only : mpas_pool_get_config, mpas_pool_get_dimension, mpas_pool_get_subpool, mpas_pool_get_array + use mpas_dmpar, only : mpas_dmpar_max_int + + implicit none + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: blockList + type (MPAS_streamManager_type), pointer :: streamManager + integer, intent(out) :: ierr + + character(len=StrKIND) :: input_interval + logical, pointer :: config_apply_lbcs => null() + integer, pointer :: nCellsSolve => null() + type (mpas_pool_type), pointer :: meshPool => null() + type (block_type), pointer :: block => null() + integer, dimension(:), pointer :: bdyMaskCell => null() + integer :: maxvar2d_local, maxvar2d_global + + + call mpas_pool_get_config(blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + + call mpas_log_write('') + call mpas_log_write('Checking consistency of limited-area settings...') + call mpas_log_write(' - config_apply_lbcs = $l', logicArgs=(/config_apply_lbcs/)) + + ! + ! Check whether any elements of bdyMaskCell have non-zero values + ! + maxvar2d_local = -huge(maxvar2d_local) + block => blockList + do while (associated(block)) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_dimension(meshPool, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_array(meshPool, 'bdyMaskCell', bdyMaskCell) + + maxvar2d_local = max(maxvar2d_local, maxval(bdyMaskCell(1:nCellsSolve))) + + block => block % next + end do + + call mpas_dmpar_max_int(dminfo, maxvar2d_local, maxvar2d_global) + call mpas_log_write(' - Maximum value in bdyMaskCell = $i', intArgs=(/maxvar2d_global/)) + + ! + ! If there are boundary cells, config_apply_lbcs must be set to true + ! + if (.not. config_apply_lbcs .and. maxvar2d_global > 0) then + call mpas_log_write('Boundary cells found in the bdyMaskCell field, but config_apply_lbcs = false.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Please ensure that config_apply_lbcs = true for limited-area simulations.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! + ! If there are no boundary cells, config_apply_lbcs must be set to false + ! + if (config_apply_lbcs .and. maxvar2d_global == 0) then + call mpas_log_write('config_apply_lbcs = true, but no boundary cells found in the bdyMaskCell field.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Please ensure that config_apply_lbcs = false for global simulations.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! + ! If config_apply_lbcs = true, check that the 'lbc_in' stream has a valid input interval + ! + if (config_apply_lbcs) then + call mpas_stream_mgr_get_property(streamManager, 'lbc_in', MPAS_STREAM_PROPERTY_RECORD_INTV, & + input_interval, MPAS_STREAM_INPUT, ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Unable to retrieve input interval for the ''lbc_in'' stream.', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + call mpas_log_write(' - Input interval for ''lbc_in'' stream = '''//trim(input_interval)//'''') + if (trim(input_interval) == 'none') then + call mpas_log_write('Input interval for the ''lbc_in'' stream must be a valid interval '// & + 'when config_apply_lbcs = true.', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + end if + + call mpas_log_write(' ----- done checking limited-area settings -----') + call mpas_log_write('') + ierr = 0 + + end subroutine mpas_atm_bdy_checks + +end module mpas_atm_boundaries diff --git a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F index 7449b06b1f..e2bafe8752 100644 --- a/src/core_atmosphere/dynamics/mpas_atm_time_integration.F +++ b/src/core_atmosphere/dynamics/mpas_atm_time_integration.F @@ -6,6 +6,14 @@ ! distributed with this code, or at http://mpas-dev.github.com/license.html ! +#ifdef MPAS_OPENACC +#define MPAS_ACC_TIMER_START(X) call mpas_timer_start(X) +#define MPAS_ACC_TIMER_STOP(X) call mpas_timer_stop(X) +#else +#define MPAS_ACC_TIMER_START(X) +#define MPAS_ACC_TIMER_STOP(X) +#endif + module atm_time_integration use mpas_derived_types @@ -15,8 +23,8 @@ module atm_time_integration use mpas_dmpar use mpas_vector_reconstruction ! Added only clause to keep xlf90 from getting confused from the overloaded abs intrinsic in mpas_timekeeping - use mpas_timekeeping, only: MPAS_Time_type, MPAS_TimeInterval_type, & - mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+), add_t_ti + use mpas_derived_types, only : MPAS_Time_type, MPAS_TimeInterval_type, MPAS_NOW + use mpas_timekeeping, only: mpas_set_time, mpas_set_timeInterval, mpas_get_time, operator(+) use mpas_timer #ifdef DO_PHYSICS @@ -25,12 +33,30 @@ module atm_time_integration use mpas_atmphys_utilities #endif + use mpas_atm_boundaries, only : nSpecZone, nRelaxZone, nBdyZone, mpas_atm_get_bdy_state, mpas_atm_get_bdy_tend ! regional_MPAS addition + use mpas_atm_iau + ! + ! 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 + integer :: timerid, secs, u_secs ! Used to store physics tendencies for dynamics variables - real (kind=RKIND), allocatable, dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics + real (kind=RKIND), dimension(:,:), pointer :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics ! Used in compute_dyn_tend real (kind=RKIND), allocatable, dimension(:,:) :: qtot @@ -46,23 +72,318 @@ module atm_time_integration ! Used in atm_advance_scalars_mono real (kind=RKIND), dimension(:,:), allocatable :: scalar_old_arr, scalar_new_arr real (kind=RKIND), dimension(:,:), allocatable :: s_max_arr, s_min_arr - real (kind=RKIND), dimension(:,:,:), allocatable :: scale_array real (kind=RKIND), dimension(:,:), allocatable :: flux_array real (kind=RKIND), dimension(:,:), allocatable :: flux_upwind_tmp_arr real (kind=RKIND), dimension(:,:), allocatable :: flux_tmp_arr real (kind=RKIND), dimension(:,:), allocatable :: wdtn_arr real (kind=RKIND), dimension(:,:), allocatable :: rho_zz_int - real (kind=RKIND), dimension(:,:,:), allocatable :: scalar_tend_array + real (kind=RKIND), dimension(:,:,:), allocatable :: scalars_driving ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_tend ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_tend ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rho_driving_tend ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: ru_driving_values ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rt_driving_values ! regional_MPAS addition + real (kind=RKIND), dimension(:,:), allocatable :: rho_driving_values ! regional_MPAS addition + integer, dimension(:), pointer :: bdyMaskEdge ! regional_MPAS addition + logical, pointer :: config_apply_lbcs + ! Used in compute_solve_diagnostics real (kind=RKIND), allocatable, dimension(:,:) :: ke_vertex real (kind=RKIND), allocatable, dimension(:,:) :: ke_edge - + type (MPAS_Clock_type), pointer, private :: clock + type (block_type), pointer, private :: block + + + ! Used for Rayleigh damping on u + ! NB: We do not necessarily want this to vary with calendar, as it is used to set + ! a timescale in seconds given a timescale in days, and it could be rather confusing + ! if damping in the model changed with the simulation calendar + real (kind=RKIND), parameter, private :: seconds_per_day = 86400.0_RKIND + + contains - subroutine atm_timestep(domain, dt, timeStamp, itimestep) + !*********************************************************************** + ! + ! routine mpas_atm_dynamics_checks + ! + !> \brief Checks compatibility of dynamics settings + !> \author Michael Duda + !> \date 14 June 2023 + !> \details + !> This routine checks that dynamics settings are valid. + !> Specifically,the following are checked by this routine: + !> + !> 1) config_positive_definite == .false. + !> + !> At present only a warning is printed in the case of a failed check, + !> and a value of 0 is always returned by the ierr argument. However, + !> warnings may be escalated to errors in future. + ! + !----------------------------------------------------------------------- + subroutine mpas_atm_dynamics_checks(dminfo, blockList, streamManager, ierr) + + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : dm_info, block_type, MPAS_LOG_WARN + use mpas_pool_routines, only : mpas_pool_get_config + + implicit none + + type (dm_info), pointer :: dminfo + type (block_type), pointer :: blockList + type (MPAS_streamManager_type), pointer :: streamManager + integer, intent(out) :: ierr + + logical, pointer :: config_positive_definite + + + call mpas_log_write('') + call mpas_log_write('Checking consistency of dynamics settings...') + + ! + ! Check that config_positive_definite == .false., since the positive-definite advection + ! option is currently unimplemented. + ! + nullify(config_positive_definite) + call mpas_pool_get_config(blocklist % configs, 'config_positive_definite', config_positive_definite) + + if (config_positive_definite) then + call mpas_log_write('The positive definite advection option is currently unimplemented, and', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('setting config_positive_definite = true will enable monotonic advection.', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('Please remove the specification of config_positive_definite from the', & + messageType=MPAS_LOG_WARN) + call mpas_log_write('&nhyd_model namelist group.', & + messageType=MPAS_LOG_WARN) + end if + + call mpas_log_write(' ----- done checking dynamics settings -----') + call mpas_log_write('') + + ierr = 0 + + end subroutine mpas_atm_dynamics_checks + + + !---------------------------------------------------------------------------- + ! routine MPAS_atm_dynamics_init + ! + !> \brief Initialize the dynamics + !> \date 28 July 2021 + !> \details + !> Prepare the dynamics component of MPAS-Atmosphere for time integration. + !> This may involve, for example, allocating dynamics-local storage or + !> initializing data structures used throughout the dynamics. Since this + !> routine is called once before the first integration step, the work done + !> by this routine is generally persistent across all calls to the dynamical + !> core, in contrast to work that is performed at the beginning of each call + !> to the dynamical core. + ! + !---------------------------------------------------------------------------- + subroutine mpas_atm_dynamics_init(domain) + + implicit none + + type (domain_type), intent(inout) :: domain + +#ifdef MPAS_CAM_DYCORE + ! Used in allocating scratch fields for physics tendencies + type (mpas_pool_type), pointer :: tend_physics + type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField +#endif + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + + real (kind=RKIND), dimension(:), pointer :: dvEdge + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: advCellsForEdge + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nAdvCellsForEdge + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs_3rd + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + real (kind=RKIND), dimension(:), pointer :: invAreaCell + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskEdge +#endif + + +#ifdef MPAS_CAM_DYCORE + nullify(tend_physics) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) + + call mpas_pool_get_field(tend_physics, 'tend_rtheta_physics', tend_rtheta_physicsField) + call mpas_allocate_scratch_field(tend_rtheta_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_rho_physics', tend_rho_physicsField) + call mpas_allocate_scratch_field(tend_rho_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_ru_physics', tend_ru_physicsField) + call mpas_allocate_scratch_field(tend_ru_physicsField) +#endif + +#ifdef MPAS_OPENACC + nullify(mesh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + !$acc enter data copyin(dvEdge) + + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + !$acc enter data copyin(cellsOnCell) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + !$acc enter data copyin(cellsOnEdge) + + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + !$acc enter data copyin(advCellsForEdge) + + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + !$acc enter data copyin(edgesOnCell) + + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + !$acc enter data copyin(nAdvCellsForEdge) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + !$acc enter data copyin(nEdgesOnCell) + + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + !$acc enter data copyin(adv_coefs) + + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + !$acc enter data copyin(adv_coefs_3rd) + + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + !$acc enter data copyin(edgesOnCell_sign) + + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + !$acc enter data copyin(invAreaCell) + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + !$acc enter data copyin(bdyMaskCell) + + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + !$acc enter data copyin(bdyMaskEdge) +#endif + + end subroutine mpas_atm_dynamics_init + + + !---------------------------------------------------------------------------- + ! routine MPAS_atm_dynamics_finalize + ! + !> \brief Finalize the dynamics + !> \author Michael Duda + !> \date 28 July 2021 + !> \details + !> Finalizes the dynamics component of MPAS-Atmosphere by, for example, + !> freeing up dynamics-local memory and shut down infrastructure used only + !> in the dynamics component of MPAS-Atmosphere. This routine is called once + !> after the last integration step, and the work done here is usually the + !> inverse of that done in the mpas_atm_dynamics_init routine (e.g., + !> deallocating memory that was allocated by mpas_atm_dynamics_init). + ! + !---------------------------------------------------------------------------- + subroutine mpas_atm_dynamics_finalize(domain) + + implicit none + + type (domain_type), intent(inout) :: domain + +#ifdef MPAS_CAM_DYCORE + ! Used in allocating scratch fields for physics tendencies + type (mpas_pool_type), pointer :: tend_physics + type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField +#endif + +#ifdef MPAS_OPENACC + type (mpas_pool_type), pointer :: mesh + + real (kind=RKIND), dimension(:), pointer :: dvEdge + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: advCellsForEdge + integer, dimension(:,:), pointer :: edgesOnCell + integer, dimension(:), pointer :: nAdvCellsForEdge + integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs + real (kind=RKIND), dimension(:,:), pointer :: adv_coefs_3rd + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + real (kind=RKIND), dimension(:), pointer :: invAreaCell + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: bdyMaskEdge +#endif + + +#ifdef MPAS_CAM_DYCORE + nullify(tend_physics) + call mpas_pool_get_subpool(domain % blocklist % structs, 'tend_physics', tend_physics) + + call mpas_pool_get_field(tend_physics, 'tend_rtheta_physics', tend_rtheta_physicsField) + call mpas_deallocate_scratch_field(tend_rtheta_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_rho_physics', tend_rho_physicsField) + call mpas_deallocate_scratch_field(tend_rho_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_ru_physics', tend_ru_physicsField) + call mpas_deallocate_scratch_field(tend_ru_physicsField) +#endif + +#ifdef MPAS_OPENACC + nullify(mesh) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + !$acc exit data delete(dvEdge) + + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + !$acc exit data delete(cellsOnCell) + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + !$acc exit data delete(cellsOnEdge) + + call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) + !$acc exit data delete(advCellsForEdge) + + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + !$acc exit data delete(edgesOnCell) + + call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) + !$acc exit data delete(nAdvCellsForEdge) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + !$acc exit data delete(nEdgesOnCell) + + call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) + !$acc exit data delete(adv_coefs) + + call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) + !$acc exit data delete(adv_coefs_3rd) + + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + !$acc exit data delete(edgesOnCell_sign) + + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + !$acc exit data delete(invAreaCell) + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + !$acc exit data delete(bdyMaskCell) + + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + !$acc exit data delete(bdyMaskEdge) +#endif + + end subroutine mpas_atm_dynamics_finalize + + + subroutine atm_timestep(domain, dt, nowTime, itimestep, exchange_halo_group) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance model state forward in time by the specified time step ! @@ -76,45 +397,54 @@ subroutine atm_timestep(domain, dt, timeStamp, itimestep) type (domain_type), intent(inout) :: domain real (kind=RKIND), intent(in) :: dt - character(len=*), intent(in) :: timeStamp + type (MPAS_Time_type), intent(in) :: nowTime integer, intent(in) :: itimestep + procedure (halo_exchange_routine) :: exchange_halo_group - type (block_type), pointer :: block type (MPAS_Time_type) :: currTime type (MPAS_TimeInterval_type) :: dtInterval character (len=StrKIND), pointer :: xtime character (len=StrKIND) :: xtime_new + real (kind=RKIND), pointer :: Time + real (kind=RKIND) :: Time_new type (mpas_pool_type), pointer :: state character (len=StrKIND), pointer :: config_time_integration - call mpas_pool_get_config(domain % blocklist % configs, 'config_time_integration', config_time_integration) + clock => domain % clock + block => domain % blocklist + + call mpas_pool_get_config(block % configs, 'config_time_integration', config_time_integration) + call mpas_pool_get_config(block % configs, 'config_apply_lbcs', config_apply_lbcs) if (trim(config_time_integration) == 'SRK3') then - call atm_srk3(domain, dt, itimestep) + call atm_srk3(domain, dt, itimestep, exchange_halo_group) else call mpas_log_write('Unknown time integration option '//trim(config_time_integration), messageType=MPAS_LOG_ERR) call mpas_log_write('Currently, only ''SRK3'' is supported.', messageType=MPAS_LOG_CRIT) end if - call mpas_set_time(currTime, dateTimeString=timeStamp) call mpas_set_timeInterval(dtInterval, dt=dt) - currTime = currTime + dtInterval + currTime = nowTime + dtInterval call mpas_get_time(currTime, dateTimeString=xtime_new) - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_array(state, 'xtime', xtime, 2) - xtime = xtime_new - block => block % next - end do + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'xtime', xtime, 2) + xtime = xtime_new + + ! Get CF-compliant time at current timestep + call mpas_pool_get_array(state, 'Time', Time, 1) + Time_new = Time + dt + + ! Write CF-compliant time for advanced timestep + call mpas_pool_get_array(state, 'Time', Time, 2) + Time = Time_new end subroutine atm_timestep - subroutine atm_srk3(domain, dt, itimestep) + subroutine atm_srk3(domain, dt, itimestep, exchange_halo_group) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Advance model state forward in time by the specified time step using ! time-split RK3 scheme @@ -133,10 +463,10 @@ subroutine atm_srk3(domain, dt, itimestep) type (domain_type), intent(inout) :: domain real (kind=RKIND), intent(in) :: dt integer, intent(in) :: itimestep + procedure (halo_exchange_routine) :: exchange_halo_group integer :: thread integer :: iCell, k, iEdge - type (block_type), pointer :: block integer, pointer :: nThreads integer, dimension(:), pointer :: cellThreadStart, cellThreadEnd @@ -169,6 +499,7 @@ subroutine atm_srk3(domain, dt, itimestep) character (len=StrKIND), pointer :: config_convection_scheme integer, pointer :: num_scalars, index_qv, nCells, nCellsSolve, nEdges, nEdgesSolve, nVertices, nVerticesSolve, nVertLevels + integer, pointer :: index_qc, index_qr, index_qi, index_qs, index_qg, index_nr, index_ni, index_nc, index_nifa, index_nwfa character(len=StrKIND), pointer :: config_IAU_option @@ -177,77 +508,128 @@ subroutine atm_srk3(domain, dt, itimestep) type (mpas_pool_type), pointer :: diag_physics type (mpas_pool_type), pointer :: mesh type (mpas_pool_type), pointer :: tend - type (mpas_pool_type), pointer :: tend_physics - - type (field2DReal), pointer :: theta_m_field - type (field3DReal), pointer :: scalars_field - type (field2DReal), pointer :: pressure_p_field - type (field2DReal), pointer :: rtheta_p_field - type (field2DReal), pointer :: rtheta_pp_field - type (field2DReal), pointer :: tend_u_field - type (field2DReal), pointer :: u_field - type (field2DReal), pointer :: w_field - type (field2DReal), pointer :: rw_p_field - type (field2DReal), pointer :: ru_p_field - type (field2DReal), pointer :: rho_pp_field - type (field2DReal), pointer :: pv_edge_field - type (field2DReal), pointer :: rho_edge_field - type (field2DReal), pointer :: exner_field + type (mpas_pool_type), pointer :: tend_physics => null() + type (mpas_pool_type), pointer :: lbc ! regional_MPAS addition real (kind=RKIND), dimension(:,:), pointer :: w real (kind=RKIND), dimension(:,:), pointer :: u, uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, scalars_1, scalars_2 - real (kind=RKIND), dimension(:,:), pointer :: rqvdynten + real (kind=RKIND), dimension(:,:), pointer :: rqvdynten, rthdynten, theta_m + real (kind=RKIND) :: theta_local, fac_m + +#ifndef MPAS_CAM_DYCORE + ! Used in allocating scratch fields for physics tendencies + type (field2DReal), pointer :: tend_ru_physicsField, tend_rtheta_physicsField, tend_rho_physicsField +#endif + real (kind=RKIND) :: time_dyn_step logical, parameter :: debug = .false. ! ! Retrieve configuration options ! - call mpas_pool_get_config(domain % blocklist % configs, 'config_number_of_sub_steps', config_number_of_sub_steps) - call mpas_pool_get_config(domain % blocklist % configs, 'config_time_integration_order', config_time_integration_order) - call mpas_pool_get_config(domain % blocklist % configs, 'config_scalar_advection', config_scalar_advection) - call mpas_pool_get_config(domain % blocklist % configs, 'config_positive_definite', config_positive_definite) - call mpas_pool_get_config(domain % blocklist % configs, 'config_monotonic', config_monotonic) - call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', config_dt) - call mpas_pool_get_config(domain % blocklist % configs, 'config_microp_scheme', config_microp_scheme) - call mpas_pool_get_config(domain % blocklist % configs, 'config_convection_scheme', config_convection_scheme) - call mpas_pool_get_config(domain % blocklist % configs, 'config_IAU_option', config_IAU_option) - + call mpas_pool_get_config(block % configs, 'config_number_of_sub_steps', config_number_of_sub_steps) + call mpas_pool_get_config(block % configs, 'config_time_integration_order', config_time_integration_order) + call mpas_pool_get_config(block % configs, 'config_scalar_advection', config_scalar_advection) + call mpas_pool_get_config(block % configs, 'config_positive_definite', config_positive_definite) + call mpas_pool_get_config(block % configs, 'config_monotonic', config_monotonic) + call mpas_pool_get_config(block % configs, 'config_dt', config_dt) + call mpas_pool_get_config(block % configs, 'config_IAU_option', config_IAU_option) ! config variables for dynamics-transport splitting, WCS 18 November 2014 - call mpas_pool_get_config(domain % blocklist % configs, 'config_split_dynamics_transport', config_split_dynamics_transport) - call mpas_pool_get_config(domain % blocklist % configs, 'config_dynamics_split_steps', config_dynamics_split) + call mpas_pool_get_config(block % configs, 'config_split_dynamics_transport', config_split_dynamics_transport) + call mpas_pool_get_config(block % configs, 'config_dynamics_split_steps', config_dynamics_split) + ! config variables for cloud microphysics +#ifdef DO_PHYSICS + call mpas_pool_get_config(block % configs, 'config_microp_scheme', config_microp_scheme) + call mpas_pool_get_config(block % configs, 'config_convection_scheme', config_convection_scheme) +#endif ! ! Retrieve field structures ! - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) +#ifdef DO_PHYSICS + call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) +#endif ! - ! Retrieve fields + ! Retrieve dimensions + ! Note: nCellsSolve and nVerticesSolve are not currently used in this function ! - call mpas_pool_get_field(state, 'theta_m', theta_m_field, 1) - call mpas_pool_get_field(state, 'scalars', scalars_field, 1) - call mpas_pool_get_field(diag, 'pressure_p', pressure_p_field) - call mpas_pool_get_field(diag, 'rtheta_p', rtheta_p_field) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + + !call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) + !call mpas_pool_get_dimension(mesh, 'nVerticesSolve', nVerticesSolve) + + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + + +#ifdef DO_PHYSICS + call mpas_pool_get_dimension(state, 'index_qv', index_qv) +#endif + if (config_apply_lbcs) then + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + 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) + call mpas_pool_get_dimension(state, 'index_nr', index_nr) + call mpas_pool_get_dimension(state, 'index_ni', index_ni) + call mpas_pool_get_dimension(state, 'index_nc', index_nc) + call mpas_pool_get_dimension(state, 'index_nifa', index_nifa) + call mpas_pool_get_dimension(state, 'index_nwfa', index_nwfa) + endif ! ! allocate storage for physics tendency save ! - call mpas_pool_get_dimension(state, 'nCells', nCells) - call mpas_pool_get_dimension(state, 'nEdges', nEdges) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - allocate(qtot(nVertLevels,nCells+1)) qtot(:,nCells+1) = 0.0_RKIND - allocate(tend_rtheta_physics(nVertLevels,nCells+1)) + +#ifndef MPAS_CAM_DYCORE + call mpas_pool_get_field(tend_physics, 'tend_rtheta_physics', tend_rtheta_physicsField) + call mpas_allocate_scratch_field(tend_rtheta_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_rho_physics', tend_rho_physicsField) + call mpas_allocate_scratch_field(tend_rho_physicsField) + + call mpas_pool_get_field(tend_physics, 'tend_ru_physics', tend_ru_physicsField) + call mpas_allocate_scratch_field(tend_ru_physicsField) +#endif + + call mpas_pool_get_array(tend_physics, 'tend_rtheta_physics', tend_rtheta_physics) tend_rtheta_physics(:,nCells+1) = 0.0_RKIND - allocate(tend_rho_physics(nVertLevels,nCells+1)) + call mpas_pool_get_array(tend_physics, 'tend_rho_physics', tend_rho_physics) tend_rho_physics(:,nCells+1) = 0.0_RKIND - allocate(tend_ru_physics(nVertLevels,nEdges+1)) + call mpas_pool_get_array(tend_physics, 'tend_ru_physics', tend_ru_physics) tend_ru_physics(:,nEdges+1) = 0.0_RKIND ! @@ -296,148 +678,70 @@ subroutine atm_srk3(domain, dt, itimestep) number_sub_steps(3) = number_of_sub_steps end if - -! theta_m - call mpas_dmpar_exch_halo_field(theta_m_field) - -! scalars - call mpas_dmpar_exch_halo_field(scalars_field) - -! pressure_p - call mpas_dmpar_exch_halo_field(pressure_p_field) - -! rtheta_p - call mpas_dmpar_exch_halo_field(rtheta_p_field) + ! + ! Communicate halos for theta_m, scalars, pressure_p, and rtheta_p + ! + call exchange_halo_group(domain, 'dynamics:theta_m,scalars,pressure_p,rtheta_p') call mpas_timer_start('atm_rk_integration_setup') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - ! mesh is needed for atm_compute_moist_coefficients - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - !$OMP PARALLEL DO - do thread=1,nThreads - call atm_rk_integration_setup(state, diag, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_rk_integration_setup(state, diag, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_rk_integration_setup') call mpas_timer_start('atm_compute_moist_coefficients') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - ! mesh is needed for atm_compute_moist_coefficients - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_moist_coefficients( block % dimensions, state, diag, mesh, & !MGD could do away with dimensions arg - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_compute_moist_coefficients( block % dimensions, state, diag, mesh, & !MGD could do away with dimensions arg + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_compute_moist_coefficients') #ifdef DO_PHYSICS call mpas_timer_start('physics_get_tend') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) - rk_step = 1 - dynamics_substep = 1 - call physics_get_tend( block, & - mesh, & - state, & - diag, & - tend, & - tend_physics, & - block % configs, & - rk_step, & - dynamics_substep, & - tend_ru_physics, & - tend_rtheta_physics, & - tend_rho_physics ) - block => block % next - end do + rk_step = 1 + dynamics_substep = 1 + call physics_get_tend( block, mesh, state, diag, tend, tend_physics, & + block % configs, rk_step, dynamics_substep, & + tend_ru_physics, tend_rtheta_physics, tend_rho_physics, & + exchange_halo_group ) call mpas_timer_stop('physics_get_tend') #else +#ifndef MPAS_CAM_DYCORE ! ! If no physics are being used, simply zero-out the physics tendency fields ! tend_ru_physics(:,:) = 0.0_RKIND tend_rtheta_physics(:,:) = 0.0_RKIND tend_rho_physics(:,:) = 0.0_RKIND +#endif #endif ! ! IAU - Incremental Analysis Update ! if (trim(config_IAU_option) /= 'off') then - block => domain % blocklist - do while (associated(block)) - call atm_add_tend_anal_incr(block % configs, block % structs, itimestep, dt, & - tend_ru_physics, tend_rtheta_physics, tend_rho_physics) - block => block % next - end do + call atm_add_tend_anal_incr(block % configs, block % structs, itimestep, dt, & + tend_ru_physics, tend_rtheta_physics, tend_rho_physics) end if @@ -446,43 +750,20 @@ subroutine atm_srk3(domain, dt, itimestep) ! Compute the coefficients for the vertically implicit solve in the acoustic step. ! These coefficients will work for the first acoustic step in all cases. call mpas_timer_start('atm_compute_vert_imp_coefs') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - rk_step = 1 + rk_step = 1 !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - block => block % next + do thread=1,nThreads + call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) end do +!$OMP END PARALLEL DO call mpas_timer_stop('atm_compute_vert_imp_coefs') - call mpas_pool_get_field(diag, 'exner', exner_field) - call mpas_dmpar_exch_halo_field(exner_field) + call exchange_halo_group(domain, 'dynamics:exner') !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -496,109 +777,55 @@ subroutine atm_srk3(domain, dt, itimestep) ! Compute the coefficients for the vertically implicit solve in the acoustic step. ! These coefficients will work for the 2nd and 3rd acoustic steps (dt is the same for both). - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - block => block % next + do thread=1,nThreads + call atm_compute_vert_imp_coefs( state, mesh, diag, block % configs, nVertLevels, rk_sub_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) end do +!$OMP END PARALLEL DO end if call mpas_timer_start('atm_compute_dyn_tend') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertices', nVertices) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(delsq_theta(nVertLevels,nCells+1)) - delsq_theta(:,nCells+1) = 0.0_RKIND - allocate(delsq_w(nVertLevels,nCells+1)) - delsq_w(:,nCells+1) = 0.0_RKIND -!! allocate(qtot(nVertLevels,nCells+1)) ! initializing this earlier in solution sequence - allocate(delsq_divergence(nVertLevels,nCells+1)) - delsq_divergence(:,nCells+1) = 0.0_RKIND - allocate(delsq_u(nVertLevels,nEdges+1)) - delsq_u(:,nEdges+1) = 0.0_RKIND -!! allocate(delsq_circulation(nVertLevels,nVertices+1)) ! no longer used -> removed - allocate(delsq_vorticity(nVertLevels,nVertices+1)) - delsq_vorticity(:,nVertices+1) = 0.0_RKIND - allocate(dpdz(nVertLevels,nCells+1)) - dpdz(:,nCells+1) = 0.0_RKIND + allocate(delsq_theta(nVertLevels,nCells+1)) + delsq_theta(:,nCells+1) = 0.0_RKIND + allocate(delsq_w(nVertLevels,nCells+1)) + delsq_w(:,nCells+1) = 0.0_RKIND +!! allocate(qtot(nVertLevels,nCells+1)) ! initializing this earlier in solution sequence + allocate(delsq_divergence(nVertLevels,nCells+1)) + delsq_divergence(:,nCells+1) = 0.0_RKIND + allocate(delsq_u(nVertLevels,nEdges+1)) + delsq_u(:,nEdges+1) = 0.0_RKIND +!! allocate(delsq_circulation(nVertLevels,nVertices+1)) ! no longer used -> removed + allocate(delsq_vorticity(nVertLevels,nVertices+1)) + delsq_vorticity(:,nVertices+1) = 0.0_RKIND + allocate(dpdz(nVertLevels,nCells+1)) + dpdz(:,nCells+1) = 0.0_RKIND !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do -!$OMP END PARALLEL DO - - deallocate(delsq_theta) - deallocate(delsq_w) -!! deallocate(qtot) ! deallocation after dynamics step complete, see below - deallocate(delsq_divergence) - deallocate(delsq_u) -!! deallocate(delsq_circulation) ! no longer used -> removed - deallocate(delsq_vorticity) - deallocate(dpdz) - - block => block % next + do thread=1,nThreads + call atm_compute_dyn_tend( tend, tend_physics, state, diag, mesh, block % configs, nVertLevels, rk_step, dt, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) end do +!$OMP END PARALLEL DO + + deallocate(delsq_theta) + deallocate(delsq_w) +!! deallocate(qtot) ! deallocation after dynamics step complete, see below + deallocate(delsq_divergence) + deallocate(delsq_u) +!! deallocate(delsq_circulation) ! no longer used -> removed + deallocate(delsq_vorticity) + deallocate(dpdz) + call mpas_timer_stop('atm_compute_dyn_tend') @@ -609,45 +836,76 @@ subroutine atm_srk3(domain, dt, itimestep) !*********************************** ! tend_u - call mpas_pool_get_subpool(domain % blocklist % structs, 'tend', tend) - call mpas_pool_get_field(tend, 'u', tend_u_field) - call mpas_dmpar_exch_halo_field(tend_u_field, (/ 1 /)) + call exchange_halo_group(domain, 'dynamics:tend_u') call mpas_timer_start('small_step_prep') + +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_set_smlstep_pert_variables( tend, diag, mesh, block % configs, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do +!$OMP END PARALLEL DO + call mpas_timer_stop('small_step_prep') + + +!------------------------------------------------------------------------------------------------------------------------ - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) + if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS dry dynamics in the specified zone - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + allocate(ru_driving_tend(nVertLevels,nEdges+1)) + allocate(rt_driving_tend(nVertLevels,nCells+1)) + allocate(rho_driving_tend(nVertLevels,nCells+1)) + ru_driving_tend(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_tend( clock, block, nVertLevels, nEdges, 'ru', 0.0_RKIND ) + rt_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, block, nVertLevels, nCells, 'rtheta_m', 0.0_RKIND ) + rho_driving_tend(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_tend( clock, block, nVertLevels, nCells, 'rho_zz', 0.0_RKIND ) +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, block % configs, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + deallocate(ru_driving_tend) + deallocate(rt_driving_tend) + deallocate(rho_driving_tend) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) +! -------- next, add in the tendencies for the horizontal filters and Rayleigh damping. We will keep the spec zone and relax zone adjustments separate for now... + + allocate(ru_driving_values(nVertLevels,nEdges+1)) + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) + + time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nEdges, 'ru', time_dyn_step ) + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rho_zz', time_dyn_step ) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - !$OMP PARALLEL DO do thread=1,nThreads - call atm_set_smlstep_pert_variables( tend, diag, mesh, block % configs, & - cellThreadStart(thread), cellThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + call atm_bdy_adjust_dynamics_relaxzone_tend( block % configs, tend, state, diag, mesh, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread) ) end do !$OMP END PARALLEL DO - block => block % next - end do - call mpas_timer_stop('small_step_prep') + + deallocate(ru_driving_values) + deallocate(rt_driving_values) + deallocate(rho_driving_values) + + end if ! regional_MPAS addition + +!------------------------------------------------------------------------------------------------------------------------ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! begin acoustic steps loop @@ -655,348 +913,236 @@ subroutine atm_srk3(domain, dt, itimestep) do small_step = 1, number_sub_steps(rk_step) - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) - call mpas_dmpar_exch_halo_field(rho_pp_field, (/ 1 /)) + call exchange_halo_group(domain, 'dynamics:rho_pp') call mpas_timer_start('atm_advance_acoustic_step') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_advance_acoustic_step( state, diag, tend, mesh, block % configs, nCells, nVertLevels, & - rk_sub_timestep(rk_step), small_step, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_advance_acoustic_step( state, diag, tend, mesh, block % configs, nCells, nVertLevels, & + rk_sub_timestep(rk_step), small_step, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_advance_acoustic_step') ! rtheta_pp ! This is the only communications needed during the acoustic steps because we solve for u on all edges of owned cells - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) - call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 1 /)) + call exchange_halo_group(domain, 'dynamics:rtheta_pp') ! complete update of horizontal momentum by including 3d divergence damping at the end of the acoustic step call mpas_timer_start('atm_divergence_damping_3d') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_divergence_damping_3d( state, diag, mesh, block % configs, rk_sub_timestep(rk_step), & - edgeThreadStart(thread), edgeThreadEnd(thread) ) - end do + do thread=1,nThreads + call atm_divergence_damping_3d( state, diag, mesh, block % configs, rk_sub_timestep(rk_step), & + edgeThreadStart(thread), edgeThreadEnd(thread) ) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_divergence_damping_3d') end do ! end of acoustic steps loop - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % rw_p, (/ 1 /)) - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'rw_p', rw_p_field) - call mpas_dmpar_exch_halo_field(rw_p_field) + ! + ! Communicate halos for rw_p[1,2], ru_p[1,2], rho_pp[1,2], rtheta_pp[2] + ! + call exchange_halo_group(domain, 'dynamics:rw_p,ru_p,rho_pp,rtheta_pp') - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % diag % ru_p, (/ 2 /)) - call mpas_pool_get_field(diag, 'ru_p', ru_p_field) - call mpas_dmpar_exch_halo_field(ru_p_field) + call mpas_timer_start('atm_recover_large_step_variables') - call mpas_pool_get_field(diag, 'rho_pp', rho_pp_field) - call mpas_dmpar_exch_halo_field(rho_pp_field) +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_recover_large_step_variables( state, diag, tend, mesh, block % configs, rk_timestep(rk_step), & + number_sub_steps(rk_step), rk_step, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do +!$OMP END PARALLEL DO - ! the second layer of halo cells must be exchanged before calling atm_recover_large_step_variables - call mpas_pool_get_field(diag, 'rtheta_pp', rtheta_pp_field) - call mpas_dmpar_exch_halo_field(rtheta_pp_field, (/ 2 /)) + call mpas_timer_stop('atm_recover_large_step_variables') - call mpas_timer_start('atm_recover_large_step_variables') - block => domain % blocklist - do while (associated(block)) +!------------------------------------------------------------------- - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'tend', tend) + if (config_apply_lbcs) then - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + ! First, (re)set the value of u and ru in the specified zone at the outermost edge (we will reset all for now). + ! atm_recover_large_step_variables will not have set outermost edge velocities correctly. + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + allocate(ru_driving_values(nVertLevels,nEdges+1)) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) + time_dyn_step = dt_dynamics*real(dynamics_substep-1) + rk_timestep(rk_step) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nEdges, 'u', time_dyn_step ) + ! do this inline at present - it is simple enough + do iEdge = 1, nEdgesSolve + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k = 1, nVertLevels + u(k,iEdge) = ru_driving_values(k,iEdge) + end do + end if + end do -!$OMP PARALLEL DO - do thread=1,nThreads - call atm_recover_large_step_variables( state, diag, tend, mesh, block % configs, rk_timestep(rk_step), & - number_sub_steps(rk_step), rk_step, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + ru_driving_values(1:nVertLevels,1:nEdges+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nEdges, 'ru', time_dyn_step ) + call mpas_pool_get_array(diag, 'ru', u) + ! do this inline at present - it is simple enough + do iEdge = 1, nEdges + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k = 1, nVertLevels + u(k,iEdge) = ru_driving_values(k,iEdge) + end do + end if end do -!$OMP END PARALLEL DO + + deallocate(ru_driving_values) - block => block % next - end do - call mpas_timer_stop('atm_recover_large_step_variables') + end if ! regional_MPAS addition +!------------------------------------------------------------------- + ! u - !CR: SMALLER STENCIL?: call mpas_dmpar_exch_halo_field(block % state % time_levs(2) % state % u, (/ 3 /)) - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'u', u_field, 2) - call mpas_dmpar_exch_halo_field(u_field) + if (config_apply_lbcs) then + call exchange_halo_group(domain, 'dynamics:u_123') + else + call exchange_halo_group(domain, 'dynamics:u_3') + end if ! scalar advection: RK3 scheme of Skamarock and Gassmann (2011). ! PD or monotonicity constraints applied only on the final Runge-Kutta substep. if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_start('atm_advance_scalars') - else - call mpas_timer_start('atm_advance_scalars_mono') - end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(scalar_old_arr(nVertLevels,nCells+1)) - scalar_old_arr(:,nCells+1) = 0.0_RKIND - allocate(scalar_new_arr(nVertLevels,nCells+1)) - scalar_new_arr(:,nCells+1) = 0.0_RKIND - allocate(s_max_arr(nVertLevels,nCells+1)) - s_max_arr(:,nCells+1) = 0.0_RKIND - allocate(s_min_arr(nVertLevels,nCells+1)) - s_min_arr(:,nCells+1) = 0.0_RKIND - allocate(scale_array(nVertLevels,2,nCells+1)) - scale_array(:,:,nCells+1) = 0.0_RKIND - allocate(flux_array(nVertLevels,nEdges+1)) - flux_array(:,nEdges+1) = 0.0_RKIND - allocate(wdtn_arr(nVertLevels+1,nCells+1)) - wdtn_arr(:,nCells+1) = 0.0_RKIND - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) - horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND - else - allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) - flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND - allocate(flux_tmp_arr(nVertLevels,nEdges+1)) - flux_tmp_arr(:,nEdges+1) = 0.0_RKIND - end if + call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) + if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport + + call exchange_halo_group(domain, 'dynamics:scalars') + + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + + ! get the scalar values driving the regional boundary conditions ! - ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses - ! the functionality of the advance_scalars routine; however, it is noticeably slower, - ! so we use the advance_scalars routine for the first two RK substeps. - ! -!$OMP PARALLEL DO + if (index_qv > 0) then + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) + end if + if (index_qc > 0) then + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) + end if + if (index_qr > 0) then + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) + end if + if (index_qi > 0) then + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) + end if + if (index_qs > 0) then + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) + end if + if (index_qg > 0) then + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) + end if + if (index_nr > 0) then + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + end if + if (index_ni > 0) then + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + end if + if (index_nc > 0) then + scalars_driving(index_nc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nc', rk_timestep(rk_step) ) + end if + if (index_nifa > 0) then + scalars_driving(index_nifa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nifa', rk_timestep(rk_step) ) + end if + if (index_nwfa > 0) then + scalars_driving(index_nwfa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nwfa', rk_timestep(rk_step) ) + end if + !$OMP PARALLEL DO do thread=1,nThreads - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.false. ) - else - - block % domain = domain - call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=.false.) - end if + call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) end do -!$OMP END PARALLEL DO + !$OMP END PARALLEL DO - deallocate(scalar_old_arr) - deallocate(scalar_new_arr) - deallocate(s_max_arr) - deallocate(s_min_arr) - deallocate(scale_array) - deallocate(flux_array) - deallocate(wdtn_arr) - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - deallocate(horiz_flux_array) - else - deallocate(flux_upwind_tmp_arr) - deallocate(flux_tmp_arr) - end if + deallocate(scalars_driving) - block => block % next - end do - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_stop('atm_advance_scalars') - else - call mpas_timer_stop('atm_advance_scalars_mono') - end if + + end if ! regional_MPAS addition end if call mpas_timer_start('atm_compute_solve_diagnostics') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(state, 'nEdges', nEdges) - call mpas_pool_get_dimension(state, 'nVertices', nVertices) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - - allocate(ke_vertex(nVertLevels,nVertices+1)) - ke_vertex(:,nVertices+1) = 0.0_RKIND - allocate(ke_edge(nVertLevels,nEdges+1)) - ke_edge(:,nEdges+1) = 0.0_RKIND + allocate(ke_vertex(nVertLevels,nVertices+1)) + ke_vertex(:,nVertices+1) = 0.0_RKIND + allocate(ke_edge(nVertLevels,nEdges+1)) + ke_edge(:,nEdges+1) = 0.0_RKIND !$OMP PARALLEL DO - do thread=1,nThreads - call atm_compute_solve_diagnostics(dt, state, 2, diag, mesh, block % configs, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), rk_step) - end do + do thread=1,nThreads + call atm_compute_solve_diagnostics(dt, state, 2, diag, mesh, block % configs, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), rk_step) + end do !$OMP END PARALLEL DO - deallocate(ke_vertex) - deallocate(ke_edge) + deallocate(ke_vertex) + deallocate(ke_edge) - block => block % next - end do call mpas_timer_stop('atm_compute_solve_diagnostics') + if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then + ! + ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2], scalars[1,2] + ! + call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge,scalars') + else + ! + ! Communicate halos for w[1,2], pv_edge[1,2], rho_edge[1,2] + ! + call exchange_halo_group(domain, 'dynamics:w,pv_edge,rho_edge') + end if - ! w - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'w', w_field, 2) - call mpas_dmpar_exch_halo_field(w_field) + ! set the zero-gradient condition on w for regional_MPAS + + if ( config_apply_lbcs ) then ! regional_MPAS addition - ! pv_edge - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) - call mpas_dmpar_exch_halo_field(pv_edge_field) +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_zero_gradient_w_bdy( state, mesh, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO - ! rho_edge - call mpas_pool_get_field(diag, 'rho_edge', rho_edge_field) - call mpas_dmpar_exch_halo_field(rho_edge_field) + ! w halo values needs resetting after regional boundary update + call exchange_halo_group(domain, 'dynamics:w') - ! scalars - if (config_scalar_advection .and. (.not. config_split_dynamics_transport) ) then - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) - call mpas_dmpar_exch_halo_field(scalars_field) - end if + end if ! end of regional_MPAS addition end do RK3_DYNAMICS if (dynamics_substep < dynamics_split) then - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'theta_m', theta_m_field, 2) - call mpas_dmpar_exch_halo_field(theta_m_field) - call mpas_dmpar_exch_halo_field(pressure_p_field) - call mpas_dmpar_exch_halo_field(rtheta_p_field) + ! + ! Communicate halos for theta_m[1,2], pressure_p[1,2], and rtheta_p[1,2] + ! + call exchange_halo_group(domain, 'dynamics:theta_m,pressure_p,rtheta_p') ! ! Note: A halo exchange for 'exner' here as well as after the call @@ -1013,51 +1159,32 @@ subroutine atm_srk3(domain, dt, itimestep) ! Notes: physics tendencies for scalars should be OK coming out of dynamics call mpas_timer_start('atm_rk_dynamics_substep_finish') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) !$OMP PARALLEL DO - do thread=1,nThreads - call atm_rk_dynamics_substep_finish(state, diag, dynamics_substep, dynamics_split, & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call atm_rk_dynamics_substep_finish(state, diag, dynamics_substep, dynamics_split, & + cellThreadStart(thread), cellThreadEnd(thread), & + vertexThreadStart(thread), vertexThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & + edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - block => block % next - end do call mpas_timer_stop('atm_rk_dynamics_substep_finish') end do DYNAMICS_SUBSTEPS deallocate(qtot) ! we are finished with these now - deallocate(tend_rtheta_physics) - deallocate(tend_rho_physics) - deallocate(tend_ru_physics) + +#ifndef MPAS_CAM_DYCORE + call mpas_deallocate_scratch_field(tend_rtheta_physicsField) + call mpas_deallocate_scratch_field(tend_rho_physicsField) + call mpas_deallocate_scratch_field(tend_ru_physicsField) +#endif + ! ! split transport, at present RK3 @@ -1074,132 +1201,68 @@ subroutine atm_srk3(domain, dt, itimestep) RK3_SPLIT_TRANSPORT : do rk_step = 1, 3 ! Runge-Kutta loop - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_start('atm_advance_scalars') - else - call mpas_timer_start('atm_advance_scalars_mono') - end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) - - call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadStart', vertexThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexThreadEnd', vertexThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadStart', vertexSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'vertexSolveThreadEnd', vertexSolveThreadEnd) - - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadStart', edgeSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'edgeSolveThreadEnd', edgeSolveThreadEnd) - - allocate(scalar_old_arr(nVertLevels,nCells+1)) - scalar_old_arr(:,nCells+1) = 0.0_RKIND - allocate(scalar_new_arr(nVertLevels,nCells+1)) - scalar_new_arr(:,nCells+1) = 0.0_RKIND - allocate(s_max_arr(nVertLevels,nCells+1)) - s_max_arr(:,nCells+1) = 0.0_RKIND - allocate(s_min_arr(nVertLevels,nCells+1)) - s_min_arr(:,nCells+1) = 0.0_RKIND - allocate(scale_array(nVertLevels,2,nCells+1)) - scale_array(:,:,nCells+1) = 0.0_RKIND - allocate(flux_array(nVertLevels,nEdges+1)) - flux_array(:,nEdges+1) = 0.0_RKIND - allocate(wdtn_arr(nVertLevels+1,nCells+1)) - wdtn_arr(:,nCells+1) = 0.0_RKIND - allocate(rho_zz_int(nVertLevels,nCells+1)) - rho_zz_int(:,nCells+1) = 0.0_RKIND - allocate(scalar_tend_array(num_scalars,nVertLevels,nCells+1)) - scalar_tend_array(:,:,nCells+1) = 0.0_RKIND - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) - horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND - else - allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) - flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND - allocate(flux_tmp_arr(nVertLevels,nEdges+1)) - flux_tmp_arr(:,nEdges+1) = 0.0_RKIND - end if + call advance_scalars('scalars', domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) - ! - ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses - ! the functionality of the advance_scalars routine; however, it is noticeably slower, - ! so we use the advance_scalars routine for the first two RK substeps. - ! + if (config_apply_lbcs) then ! adjust boundary tendencies for regional_MPAS scalar transport + + ! need to fill halo for horizontal filter + call exchange_halo_group(domain, 'dynamics:scalars') + + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) - ! The latest version of atm_advance_scalars does not need the arrays scalar_tend_array or rho_zz_int - ! We can remove scalar_tend_array???? WCS 20160921 + ! get the scalar values driving the regional boundary conditions + ! + if (index_qv > 0) then + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qv', rk_timestep(rk_step) ) + end if + if (index_qc > 0) then + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qc', rk_timestep(rk_step) ) + end if + if (index_qr > 0) then + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qr', rk_timestep(rk_step) ) + end if + if (index_qi > 0) then + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qi', rk_timestep(rk_step) ) + end if + if (index_qs > 0) then + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qs', rk_timestep(rk_step) ) + end if + if (index_qg > 0) then + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qg', rk_timestep(rk_step) ) + end if + if (index_nr > 0) then + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nr', rk_timestep(rk_step) ) + end if + if (index_ni > 0) then + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', rk_timestep(rk_step) ) + end if + if (index_nc > 0) then + scalars_driving(index_nc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nc', rk_timestep(rk_step) ) + end if + if (index_nifa > 0) then + scalars_driving(index_nifa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nifa', rk_timestep(rk_step) ) + end if + if (index_nwfa > 0) then + scalars_driving(index_nwfa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nwfa', rk_timestep(rk_step) ) + end if !$OMP PARALLEL DO do thread=1,nThreads - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call atm_advance_scalars( tend, state, diag, mesh, block % configs, num_scalars, nCells, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - horiz_flux_array, rk_step, config_time_integration_order, & - advance_density=.true., scalar_tend=scalar_tend_array, rho_zz_int=rho_zz_int ) - else - - block % domain = domain - call atm_advance_scalars_mono( block, tend, state, diag, mesh, block % configs, nCells, nEdges, nVertLevels, rk_timestep(rk_step), & - cellThreadStart(thread), cellThreadEnd(thread), & - vertexThreadStart(thread), vertexThreadEnd(thread), & - edgeThreadStart(thread), edgeThreadEnd(thread), & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & - vertexSolveThreadStart(thread), vertexSolveThreadEnd(thread), & - edgeSolveThreadStart(thread), edgeSolveThreadEnd(thread), & - scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & - scale_array, flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & - advance_density=.true., rho_zz_int=rho_zz_int) - end if + call atm_bdy_adjust_scalars( state, diag, mesh, block % configs, scalars_driving, nVertLevels, dt, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) end do !$OMP END PARALLEL DO - deallocate(scalar_old_arr) - deallocate(scalar_new_arr) - deallocate(s_max_arr) - deallocate(s_min_arr) - deallocate(scale_array) - deallocate(flux_array) - deallocate(wdtn_arr) - deallocate(rho_zz_int) - deallocate(scalar_tend_array) - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - deallocate(horiz_flux_array) - else - deallocate(flux_upwind_tmp_arr) - deallocate(flux_tmp_arr) - end if + deallocate(scalars_driving) - block => block % next - end do - if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then - call mpas_timer_stop('atm_advance_scalars') - else - call mpas_timer_stop('atm_advance_scalars_mono') - end if + + end if ! regional_MPAS addition + +!------------------------------------------------------------------------------------------------------------------------ if (rk_step < 3) then - call mpas_pool_get_field(state, 'scalars', scalars_field, 2) - call mpas_dmpar_exch_halo_field(scalars_field) + call exchange_halo_group(domain, 'dynamics:scalars') end if end do RK3_SPLIT_TRANSPORT @@ -1209,29 +1272,21 @@ subroutine atm_srk3(domain, dt, itimestep) ! ! reconstruct full velocity vectors at cell centers: ! - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) + call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) + call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) + call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) + call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) + + call mpas_reconstruct(mesh, u, & + uReconstructX, & + uReconstructY, & + uReconstructZ, & + uReconstructZonal, & + uReconstructMeridional & + ) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'uReconstructX', uReconstructX) - call mpas_pool_get_array(diag, 'uReconstructY', uReconstructY) - call mpas_pool_get_array(diag, 'uReconstructZ', uReconstructZ) - call mpas_pool_get_array(diag, 'uReconstructZonal', uReconstructZonal) - call mpas_pool_get_array(diag, 'uReconstructMeridional', uReconstructMeridional) - - call mpas_reconstruct(mesh, u, & - uReconstructX, & - uReconstructY, & - uReconstructZ, & - uReconstructZonal, & - uReconstructMeridional & - ) - - block => block % next - end do ! ! call to parameterizations of cloud microphysics. calculation of the tendency of water vapor to horizontal and @@ -1239,57 +1294,51 @@ subroutine atm_srk3(domain, dt, itimestep) ! #ifdef DO_PHYSICS - block => domain % blocklist - do while(associated(block)) + call mpas_pool_get_array(state, 'scalars', scalars_1, 1) + call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) - call mpas_pool_get_subpool(block % structs, 'tend_physics', tend_physics) - call mpas_pool_get_subpool(block % structs, 'tend', tend) - call mpas_pool_get_array(state, 'scalars', scalars_1, 1) - call mpas_pool_get_array(state, 'scalars', scalars_2, 2) - call mpas_pool_get_dimension(state, 'index_qv', index_qv) + if(config_convection_scheme == 'cu_grell_freitas' .or. & + config_convection_scheme == 'cu_ntiedtke') then - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - if(config_convection_scheme == 'cu_grell_freitas' .or. & - config_convection_scheme == 'cu_tiedtke' .or. & - config_convection_scheme == 'cu_ntiedtke') then + !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio + !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo + !update for the scalars at time_levs(1) is applied. A halo update for the scalars at time_levs(2) is done above. + if (config_monotonic) then + rqvdynten(:,:) = ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt + else + rqvdynten(:,:) = 0._RKIND + end if - call mpas_pool_get_array(tend_physics, 'rqvdynten', rqvdynten) + do k = 1, nVertLevels + do iCell = 1, nCellsSolve + fac_m = 1._RKIND/(1._RKIND + rv/rgas*scalars_2(index_qv,k,iCell)) + theta_local = theta_m(k,iCell)*fac_m + rthdynten(k,iCell) = fac_m*(rthdynten(k,iCell)-theta_local*rv/rgas*rqvdynten(k,iCell)) + end do + end do - !NOTE: The calculation of the tendency due to horizontal and vertical advection for the water vapor mixing ratio - !requires that the subroutine atm_advance_scalars_mono was called on the third Runge Kutta step, so that a halo - !update for the scalars at time_levs(1) is applied. A halo update for the scalars at time_levs(2) is done above. - if (config_monotonic) then - rqvdynten(:,:) = ( scalars_2(index_qv,:,:) - scalars_1(index_qv,:,:) ) / config_dt - else - rqvdynten(:,:) = 0._RKIND - end if - end if + end if - !simply set to zero negative mixing ratios of different water species (for now): - where ( scalars_2(:,:,:) < 0.0) & - scalars_2(:,:,:) = 0.0 + !simply set to zero negative mixing ratios of different water species (for now): + where ( scalars_2(:,:,:) < 0.0) & + scalars_2(:,:,:) = 0.0 - !call microphysics schemes: - if (trim(config_microp_scheme) /= 'off') then - call mpas_timer_start('microphysics') + !call microphysics schemes: + if (trim(config_microp_scheme) /= 'off') then + call mpas_timer_start('microphysics') !$OMP PARALLEL DO - do thread=1,nThreads - call driver_microphysics ( block % configs, mesh, state, 2, diag, diag_physics, tend, itimestep, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) - end do + do thread=1,nThreads + call driver_microphysics ( block % configs, mesh, state, 2, diag, diag_physics, tend_physics, tend, itimestep, & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + end do !$OMP END PARALLEL DO - call mpas_timer_stop('microphysics') - end if - block => block % next - end do + call mpas_timer_stop('microphysics') + end if ! ! Note: A halo exchange for 'exner' here as well as at the end of @@ -1300,28 +1349,276 @@ subroutine atm_srk3(domain, dt, itimestep) ! #endif - call summarize_timestep(domain) + if (config_apply_lbcs) then ! reset boundary values of rtheta in the specified zone - microphysics has messed with them - end subroutine atm_srk3 + allocate(rt_driving_values(nVertLevels,nCells+1)) + allocate(rho_driving_values(nVertLevels,nCells+1)) + time_dyn_step = dt ! end of full timestep values + rt_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rtheta_m', time_dyn_step ) + rho_driving_values(1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'rho_zz', time_dyn_step ) - subroutine atm_rk_integration_setup( state, diag, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & + rt_driving_values, rho_driving_values, & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO - implicit none + deallocate(rt_driving_values) + deallocate(rho_driving_values) - type (mpas_pool_type), intent(inout) :: state - type (mpas_pool_type), intent(inout) :: diag - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + end if ! regional_MPAS addition - real (kind=RKIND), dimension(:,:), pointer :: ru - real (kind=RKIND), dimension(:,:), pointer :: ru_save - real (kind=RKIND), dimension(:,:), pointer :: rw - real (kind=RKIND), dimension(:,:), pointer :: rw_save - real (kind=RKIND), dimension(:,:), pointer :: rtheta_p - real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save + + if (config_apply_lbcs) then ! adjust boundary values for regional_MPAS scalar transport + + call exchange_halo_group(domain, 'dynamics:scalars') + + allocate(scalars_driving(num_scalars,nVertLevels,nCells+1)) + + ! get the scalar values driving the regional boundary conditions + ! + if (index_qv > 0) then + scalars_driving(index_qv,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qv', dt ) + end if + if (index_qc > 0) then + scalars_driving(index_qc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qc', dt ) + end if + if (index_qr > 0) then + scalars_driving(index_qr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qr', dt ) + end if + if (index_qi > 0) then + scalars_driving(index_qi,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qi', dt ) + end if + if (index_qs > 0) then + scalars_driving(index_qs,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qs', dt ) + end if + if (index_qg > 0) then + scalars_driving(index_qg,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'qg', dt ) + end if + if (index_nr > 0) then + scalars_driving(index_nr,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nr', dt ) + end if + if (index_ni > 0) then + scalars_driving(index_ni,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'ni', dt ) + end if + if (index_nc > 0) then + scalars_driving(index_nc,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nc', dt ) + end if + if (index_nifa > 0) then + scalars_driving(index_nifa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nifa', dt ) + end if + if (index_nwfa > 0) then + scalars_driving(index_nwfa,1:nVertLevels,1:nCells+1) = mpas_atm_get_bdy_state( clock, block, nVertLevels, nCells, 'nwfa', dt ) + end if +!$OMP PARALLEL DO + do thread=1,nThreads + call atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & + cellThreadStart(thread), cellThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread) ) + end do +!$OMP END PARALLEL DO + + deallocate(scalars_driving) + + end if ! regional_MPAS addition + + call summarize_timestep(domain) + + end subroutine atm_srk3 + + + !----------------------------------------------------------------------- + ! routine advance_scalars + ! + !> \brief Advance the scalar fields + !> \date 10 February 2020 + !> \details + !> Manages the advance of the model scalar fields, taking into account + !> runtime selection of monotonicity and scalar transport splitting. + !> + !> The first argument, field_name, indicates the base name for the array + !> of scalars to be advected. It is assumed that, if the name of + !> the array is XYZ, then there will exist: + !> + !> (1) An array in the 'state' pool named XYZ with dimensions + !> (num_XYZ, nVertLevels, nCells) and two time levels + !> + !> (2) A dimension, num_XYZ, in the 'state' pool + !> + !> (3) An array in the 'tend' pool named XYZ_tend with dimensions + !> (num_XYZ, nVertLevels, nCells) and one time level + !> + !> The scalars arrays can either be var_arrays formed from multiple + !> constituents, each with dimensions (nVertLevels, nCells), or they can + !> simply be vars with dimensions (num_???, nVertLevels, nCells). + ! + !----------------------------------------------------------------------- + subroutine advance_scalars(field_name, domain, rk_step, rk_timestep, config_monotonic, config_positive_definite, & + config_time_integration_order, config_split_dynamics_transport, exchange_halo_group) + + implicit none + + ! Arguments + character(len=*), intent(in) :: field_name + type (domain_type), intent(inout) :: domain + integer, intent(in) :: rk_step + real(kind=RKIND), dimension(:), intent(in) :: rk_timestep + logical, intent(in) :: config_monotonic + logical, intent(in) :: config_positive_definite + integer, intent(in) :: config_time_integration_order + logical, intent(in) :: config_split_dynamics_transport + procedure (halo_exchange_routine) :: exchange_halo_group + + ! Local variables + integer :: thread + + type (mpas_pool_type), pointer :: tend + type (mpas_pool_type), pointer :: state + type (mpas_pool_type), pointer :: diag + type (mpas_pool_type), pointer :: mesh + type (mpas_pool_type), pointer :: halo_scratch + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: nVertLevels + integer, pointer :: num_scalars + + integer, pointer :: nThreads + integer, dimension(:), pointer :: cellThreadStart + integer, dimension(:), pointer :: cellThreadEnd + integer, dimension(:), pointer :: cellSolveThreadStart + integer, dimension(:), pointer :: cellSolveThreadEnd + integer, dimension(:), pointer :: edgeThreadStart + integer, dimension(:), pointer :: edgeThreadEnd + + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call mpas_timer_start('atm_advance_scalars') + else + call mpas_timer_start('atm_advance_scalars_mono') + end if + + call mpas_pool_get_subpool(block % structs, 'tend', tend) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block % structs, 'halo_scratch', halo_scratch) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) + + call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + + call mpas_pool_get_dimension(block % dimensions, 'cellThreadStart', cellThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellThreadEnd', cellThreadEnd) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadStart', edgeThreadStart) + call mpas_pool_get_dimension(block % dimensions, 'edgeThreadEnd', edgeThreadEnd) + + allocate(scalar_old_arr(nVertLevels,nCells+1)) + scalar_old_arr(:,nCells+1) = 0.0_RKIND + allocate(scalar_new_arr(nVertLevels,nCells+1)) + scalar_new_arr(:,nCells+1) = 0.0_RKIND + allocate(s_max_arr(nVertLevels,nCells+1)) + s_max_arr(:,nCells+1) = 0.0_RKIND + allocate(s_min_arr(nVertLevels,nCells+1)) + s_min_arr(:,nCells+1) = 0.0_RKIND + allocate(flux_array(nVertLevels,nEdges+1)) + flux_array(:,nEdges+1) = 0.0_RKIND + allocate(wdtn_arr(nVertLevels+1,nCells+1)) + wdtn_arr(:,nCells+1) = 0.0_RKIND + if (config_split_dynamics_transport) then + allocate(rho_zz_int(nVertLevels,nCells+1)) + rho_zz_int(:,nCells+1) = 0.0_RKIND + else + allocate(rho_zz_int(1,1)) + end if + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + allocate(horiz_flux_array(num_scalars,nVertLevels,nEdges+1)) + horiz_flux_array(:,:,nEdges+1) = 0.0_RKIND + else + allocate(flux_upwind_tmp_arr(nVertLevels,nEdges+1)) + flux_upwind_tmp_arr(:,nEdges+1) = 0.0_RKIND + allocate(flux_tmp_arr(nVertLevels,nEdges+1)) + flux_tmp_arr(:,nEdges+1) = 0.0_RKIND + end if + + ! + ! Note: The advance_scalars_mono routine can be used without limiting, and thus, encompasses + ! the functionality of the advance_scalars routine; however, it is noticeably slower, + ! so we use the advance_scalars routine for the first two RK substeps. + ! + !$OMP PARALLEL DO + do thread=1,nThreads + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call atm_advance_scalars(field_name, tend, state, diag, mesh, block % configs, rk_timestep(rk_step), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + horiz_flux_array, rk_step, config_time_integration_order, & + advance_density=config_split_dynamics_transport) + else + call atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, halo_scratch, & + block % configs, rk_timestep(rk_step), & + cellThreadStart(thread), cellThreadEnd(thread), & + edgeThreadStart(thread), edgeThreadEnd(thread), & + cellSolveThreadStart(thread), cellSolveThreadEnd(thread), & + scalar_old_arr, scalar_new_arr, s_max_arr, s_min_arr, wdtn_arr, & + flux_array, flux_upwind_tmp_arr, flux_tmp_arr, & + exchange_halo_group, & + advance_density=config_split_dynamics_transport, rho_zz_int=rho_zz_int) + end if + end do + !$OMP END PARALLEL DO + + deallocate(scalar_old_arr) + deallocate(scalar_new_arr) + deallocate(s_max_arr) + deallocate(s_min_arr) + deallocate(flux_array) + deallocate(wdtn_arr) + deallocate(rho_zz_int) + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + deallocate(horiz_flux_array) + else + deallocate(flux_upwind_tmp_arr) + deallocate(flux_tmp_arr) + end if + + if (rk_step < 3 .or. (.not. config_monotonic .and. .not. config_positive_definite)) then + call mpas_timer_stop('atm_advance_scalars') + else + call mpas_timer_stop('atm_advance_scalars_mono') + end if + + end subroutine advance_scalars + + + subroutine atm_rk_integration_setup( state, diag, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + implicit none + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: ru_save + real (kind=RKIND), dimension(:,:), pointer :: rw + real (kind=RKIND), dimension(:,:), pointer :: rw_save + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save real (kind=RKIND), dimension(:,:), pointer :: rho_p real (kind=RKIND), dimension(:,:), pointer :: rho_p_save real (kind=RKIND), dimension(:,:), pointer :: rho_zz_old_split @@ -1673,11 +1970,15 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs, & real (kind=RKIND), dimension(:,:), pointer :: rw_p, rw_save, rw real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + integer, dimension(:), pointer :: bdyMaskCell ! regional_MPAS call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) +! regional_MPAS: get specified zone cell mask + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'zz', zz) call mpas_pool_get_array(mesh, 'zb', zb) call mpas_pool_get_array(mesh, 'zb3', zb3) @@ -1716,7 +2017,9 @@ subroutine atm_set_smlstep_pert_variables( tend, diag, mesh, configs, & call atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & nEdgesOnCell, cellsOnEdge, edgesOnCell, fzm, fzp, ruAvg, wwAvg, zb, zb3, zb_cell, zb3_cell, & zz, w_tend, u_tend, rho_pp, rho_p_save, rho_p, ru_p, ru, ru_save, & - rtheta_pp, rtheta_p_save, rtheta_p, rtheta_pp_old, rw_p, rw_save, rw, edgesOnCell_sign, & + rtheta_pp, rtheta_p_save, rtheta_p, rtheta_pp_old, rw_p, rw_save, rw, & + bdyMaskCell, & ! added for regional_MPAS + edgesOnCell_sign, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -1727,7 +2030,9 @@ end subroutine atm_set_smlstep_pert_variables subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & nEdgesOnCell, cellsOnEdge, edgesOnCell, fzm, fzp, ruAvg, wwAvg, zb, zb3, zb_cell, zb3_cell, & zz, w_tend, u_tend, rho_pp, rho_p_save, rho_p, ru_p, ru, ru_save, & - rtheta_pp, rtheta_p_save, rtheta_p, rtheta_pp_old, rw_p, rw_save, rw, edgesOnCell_sign, & + rtheta_pp, rtheta_p_save, rtheta_p, rtheta_pp_old, rw_p, rw_save, rw, & + bdyMaskCell, & ! added for regional_MPAS + edgesOnCell_sign, & cellStart, cellEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -1773,6 +2078,8 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + integer, dimension(nCells+1), intent(in) :: bdyMaskCell ! added for regional_MPAS + ! ! Local variables ! @@ -1787,6 +2094,8 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & !! do iCell=cellStart,cellEnd do iCell=cellSolveStart,cellSolveEnd + + if (bdyMaskCell(iCell) <= nRelaxZone) then ! no conversion in specified zone, regional_MPAS do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) !DIR$ IVDEP @@ -1800,6 +2109,7 @@ subroutine atm_set_smlstep_pert_variables_work(nCells, nEdges, nCellsSolve, & do k = 2, nVertLevels w_tend(k,iCell) = ( fzm(k) * zz(k,iCell) + fzp(k) * zz(k-1,iCell) ) * w_tend(k,iCell) end do + end if ! no conversion in specified zone end do end subroutine atm_set_smlstep_pert_variables_work @@ -1850,6 +2160,7 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, real (kind=RKIND), dimension(:), pointer :: fzm, fzp, rdzw, dcEdge, invDcEdge, invAreaCell, cofrz, dvEdge integer, dimension(:), pointer :: nEdgesOnCell + real (kind=RKIND), dimension(:), pointer :: specZoneMaskCell, specZoneMaskEdge integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign @@ -1863,6 +2174,8 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) + call mpas_pool_get_array(mesh, 'specZoneMaskCell', specZoneMaskCell) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) ! call mpas_pool_get_array(state, 'theta_m', theta_m, 2) @@ -1930,7 +2243,8 @@ subroutine atm_advance_acoustic_step( state, diag, tend, mesh, configs, nCells, rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3 & + dts, small_step, epssm, cf1, cf2, cf3, & + specZoneMaskEdge, specZoneMaskCell & ) end subroutine atm_advance_acoustic_step @@ -1942,7 +2256,8 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rho_pp, cofwt, coftz, zxu, a_tri, alpha_tri, gamma_tri, dss, tend_ru, tend_rho, tend_rt, & tend_rw, zgrid, cofwr, cofwz, w, ru, ru_save, rw, rw_save, fzm, fzp, rdzw, dcEdge, invDcEdge, & invAreaCell, cofrz, dvEdge, nEdgesOnCell, cellsOnEdge, edgesOnCell, edgesOnCell_sign, & - dts, small_step, epssm, cf1, cf2, cf3 & + dts, small_step, epssm, cf1, cf2, cf3, & + specZoneMaskEdge, specZoneMaskCell & ) use mpas_atm_dimensions @@ -2006,6 +2321,10 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart integer, dimension(maxEdges,nCells+1) :: edgesOnCell real (kind=RKIND), dimension(maxEdges,nCells+1) :: edgesOnCell_sign + real (kind=RKIND), dimension(nCells+1) :: specZoneMaskCell + real (kind=RKIND), dimension(nEdges+1) :: specZoneMaskEdge + + integer, intent(in) :: small_step real (kind=RKIND), intent(in) :: dts, epssm,cf1, cf2, cf3 real (kind=RKIND), dimension(nVertLevels) :: ts, rs @@ -2049,7 +2368,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart pgrad = ((rtheta_pp(k,cell2)-rtheta_pp(k,cell1))*invDcEdge(iEdge) )/(.5*(zz(k,cell2)+zz(k,cell1))) pgrad = cqu(k,iEdge)*0.5*c2*(exner(k,cell1)+exner(k,cell2))*pgrad pgrad = pgrad + 0.5*zxu(k,iEdge)*gravity*(rho_pp(k,cell1)+rho_pp(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - pgrad) + ru_p(k,iEdge) = ru_p(k,iEdge) + dts*(tend_ru(k,iEdge) - (1.0_RKIND - specZoneMaskEdge(iEdge))*pgrad) end do ! accumulate ru_p for use later in scalar transport @@ -2082,6 +2401,7 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart end do end if ! end test for block-owned cells + end do ! end loop over edges end if ! test for first acoustic step @@ -2100,9 +2420,6 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart do iCell=cellSolveStart,cellSolveEnd ! loop over all owned cells to solve - ts(:) = 0.0 - rs(:) = 0.0 - if(small_step == 1) then ! initialize here on first small timestep. wwAvg(1:nVertLevels+1,iCell) = 0.0 rho_pp(1:nVertLevels,iCell) = 0.0 @@ -2110,6 +2427,11 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart rw_p(:,iCell) = 0.0 end if + if(specZoneMaskCell(iCell) == 0.0) then ! not specified zone, compute... + + ts(:) = 0.0 + rs(:) = 0.0 + do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) cell1 = cellsOnEdge(1,iEdge) @@ -2191,6 +2513,17 @@ subroutine atm_advance_acoustic_step_work(nCells, nEdges, nCellsSolve, cellStart -coftz(k ,iCell)*rw_p(k ,iCell)) end do + else ! specifed zone in regional_MPAS + + do k=1,nVertLevels + rho_pp(k,iCell) = rho_pp(k,iCell) + dts*tend_rho(k,iCell) + rtheta_pp(k,iCell) = rtheta_pp(k,iCell) + dts*tend_rt(k,iCell) + rw_p(k,iCell) = rw_p(k,iCell) + dts*tend_rw(k,iCell) + wwAvg(k,iCell) = wwAvg(k,iCell) + 0.5*(1.0+epssm)*rw_p(k,iCell) + end do + + end if + end do ! end of loop over cells end subroutine atm_advance_acoustic_step_work @@ -2212,6 +2545,7 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart real (kind=RKIND), dimension(:,:), pointer :: theta_m, ru_p, rtheta_pp, rtheta_pp_old ! real (kind=RKIND), dimension(:), pointer :: dcEdge real (kind=RKIND), pointer :: smdiv, config_len_disp + real (kind=RKIND), dimension(:), pointer :: specZoneMaskEdge integer, dimension(:,:), pointer :: cellsOnEdge integer, pointer :: nCellsSolve @@ -2221,6 +2555,7 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart integer :: cell1, cell2, iEdge, k call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'specZoneMaskEdge', specZoneMaskEdge) ! call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) call mpas_pool_get_array(state, 'theta_m', theta_m, 1) call mpas_pool_get_array(diag, 'rtheta_pp', rtheta_pp) @@ -2256,7 +2591,7 @@ subroutine atm_divergence_damping_3d( state, diag, mesh, configs, dts, edgeStart !! scaled 3d divergence damping divCell1 = -(rtheta_pp(k,cell1)-rtheta_pp_old(k,cell1)) divCell2 = -(rtheta_pp(k,cell2)-rtheta_pp_old(k,cell2)) - ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1) & + ru_p(k,iEdge) = ru_p(k,iEdge) + coef_divdamp*(divCell2-divCell1)*(1.0_RKIND - specZoneMaskEdge(iEdge)) & /(theta_m(k,cell1)+theta_m(k,cell2)) end do @@ -2305,6 +2640,7 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d real (kind=RKIND) :: invNs, rcv, p0, flux real (kind=RKIND), pointer :: cf1, cf2, cf3 + integer, dimension(:), pointer :: bdyMaskCell ! MPAS_regional addition call mpas_pool_get_array(diag, 'wwAvg', wwAvg) call mpas_pool_get_array(diag, 'rw_save', rw_save) @@ -2338,6 +2674,8 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d call mpas_pool_get_array(diag, 'pressure_p', pressure_p) call mpas_pool_get_array(diag, 'pressure_base', pressure_b) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! addition for regional_MPAS + call mpas_pool_get_array(mesh, 'zz', zz) call mpas_pool_get_array(mesh, 'zb', zb) call mpas_pool_get_array(mesh, 'zb3', zb3) @@ -2367,6 +2705,7 @@ subroutine atm_recover_large_step_variables( state, diag, tend, mesh, configs, d rtheta_base, pressure_p, zz, theta_m, pressure_b, scalars, fzm, fzp, & zb, zb3, zb_cell, zb3_cell, edgesOnCell_sign, cellsOnEdge, edgesOnCell, nEdgesOnCell, & cf1, cf2, cf3, & + bdyMaskCell, & ! addition for regional_MPAS cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2379,6 +2718,7 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE rtheta_base, pressure_p, zz, theta_m, pressure_b, scalars, fzm, fzp, & zb, zb3, zb_cell, zb3_cell, edgesOnCell_sign, cellsOnEdge, edgesOnCell, nEdgesOnCell, & cf1, cf2, cf3, & + bdyMaskCell, & ! addition for regional_MPAS cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -2394,6 +2734,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE integer, intent(in) :: ns, rk_step real (kind=RKIND), intent(in) :: dt + integer, dimension(nCells+1), intent(in) :: bdyMaskCell + real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: wwAvg real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: rw_save real (kind=RKIND), dimension(nVertLevels+1,nCells+1) :: w @@ -2530,6 +2872,8 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE ! to use the same flux-divergence operator as is used for the horizontal theta transport ! (See Klemp et al 2003). + if (bdyMaskCell(iCell) <= nRelaxZone) then ! addition for regional_MPAS, no spec zone update + do i=1,nEdgesOnCell(iCell) iEdge=edgesOnCell(i,iCell) @@ -2547,57 +2891,59 @@ subroutine atm_recover_large_step_variables_work(nCells, nEdges, nCellsSolve, nE end do w(1,iCell) = w(1,iCell)/(cf1*rho_zz(1,iCell)+cf2*rho_zz(2,iCell)+cf3*rho_zz(3,iCell)) -!DIR$ IVDEP + + + !DIR$ IVDEP do k = 2, nVertLevels w(k,iCell) = w(k,iCell)/(fzm(k)*rho_zz(k,iCell)+fzp(k)*rho_zz(k-1,iCell)) end do + end if ! addition for regional_MPAS, no spec zone update + end do end subroutine atm_recover_large_step_variables_work - subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - horiz_flux_arr, rk_step, config_time_integration_order, advance_density, scalar_tend, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + ! routine atm_advance_scalars ! - ! Integrate scalar equations - explicit transport plus other tendencies + !> \brief Integrate scalar equations - explicit transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This routine is a wrapper for atm_advance_scalars_work and is primarily + !> intended to allow pointers to fields to be dereferenced through the call + !> to the work routine. ! - ! Wrapper for atm_advance_scalars_work() to de-reference pointers - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars(field_name, tend, state, diag, mesh, configs, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + horiz_flux_arr, rk_step, config_time_integration_order, advance_density) implicit none + ! Arguments + character(len=*), intent(in) :: field_name type (mpas_pool_type), intent(in) :: tend type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: num_scalars ! for allocating stack variables - integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels ! for allocating stack variables integer, intent(in) :: rk_step ! rk substep we are integrating integer, intent(in) :: config_time_integration_order ! time integration order real (kind=RKIND) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd logical, intent(in), optional :: advance_density - real (kind=RKIND), dimension(:,:,:), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int - integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 - real (kind=RKIND), dimension(:), pointer :: invAreaCell - real (kind=RKIND) :: rho_zz_new_inv - real (kind=RKIND) :: scalar_weight + ! Local variables + real (kind=RKIND), dimension(:), pointer :: invAreaCell real (kind=RKIND), dimension(:,:,:), pointer :: scalar_old, scalar_new, scalar_tend_save - real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two - real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg, rho_edge, zgrid, kdiff - real (kind=RKIND), dimension(:), pointer :: dvEdge, qv_init + real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg + real (kind=RKIND), dimension(:), pointer :: dvEdge integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:,:,:), intent(inout) :: horiz_flux_arr @@ -2605,14 +2951,18 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n integer, dimension(:), pointer :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension( num_scalars, nVertLevels + 1 ) :: wdtn - integer, pointer :: nCellsSolve, nEdges + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: num_scalars - real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw real (kind=RKIND), pointer :: coef_3rd_order + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition + logical :: local_advance_density + if (present(advance_density)) then local_advance_density = advance_density else @@ -2621,154 +2971,120 @@ subroutine atm_advance_scalars( tend, state, diag, mesh, configs, num_scalars, n call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) - call mpas_pool_get_array(state, 'scalars', scalar_old, 1) - call mpas_pool_get_array(state, 'scalars', scalar_new, 2) + call mpas_pool_get_array(state, trim(field_name), scalar_old, 1) + call mpas_pool_get_array(state, trim(field_name), scalar_new, 2) call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(diag, 'kdiff', kdiff) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend_save) - + call mpas_pool_get_array(tend, trim(field_name)//'_tend', scalar_tend_save) + call mpas_pool_get_array(mesh, 'fzm', fnm) call mpas_pool_get_array(mesh, 'fzp', fnp) call mpas_pool_get_array(mesh, 'rdzw', rdnw) - call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) - call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) call mpas_pool_get_array(mesh, 'nAdvCellsForEdge', nAdvCellsForEdge) call mpas_pool_get_array(mesh, 'advCellsForEdge', advCellsForEdge) call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - call mpas_pool_get_array(diag, 'rho_edge', rho_edge) - call mpas_pool_get_array(mesh, 'qv_init', qv_init) - call mpas_pool_get_array(mesh, 'zgrid', zgrid) - - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) - if (local_advance_density) then -! call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & -! cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & -! cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & -! coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & -! uhAvg, wwAvg, deriv_two, dvEdge, & -! cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & -! scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & -! nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & -! nCellsSolve, nEdges, horiz_flux_arr, & -! local_advance_density, scalar_tend, rho_zz_int) - call atm_advance_scalars_work_new(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & - cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - local_advance_density, scalar_tend, rho_zz_int) - else -! call atm_advance_scalars_work(num_scalars, nCells, nVertLevels, dt, & -! cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & -! cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & -! coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & -! uhAvg, wwAvg, deriv_two, dvEdge, & -! cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & -! scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & -! nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & -! nCellsSolve, nEdges, horiz_flux_arr, & -! local_advance_density) - call atm_advance_scalars_work_new(num_scalars, nCells, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + + call atm_advance_scalars_work(nCells, num_scalars, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & + uhAvg, wwAvg, dvEdge, & cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & + scalar_tend_save, fnm, fnp, rdnw, & + bdyMaskCell, bdyMaskEdge, & + nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, & + nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & local_advance_density) - end if end subroutine atm_advance_scalars - subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & - cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, & - advance_density, scalar_tend, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - explicit transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_work ! - ! WCS 18 November 2014 - !----------------------- - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata + !> \brief Integrate scalar equations - explicit transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This transport routine is similar to the original atm_advance_scalars, except + !> it also advances (re-integrates) the density. This re-integration allows the scalar + !> transport routine to use a different timestep than the dry dynamics, and also makes + !> possible a spatial splitting of the scalar transport integration (and density + !> integration). The current integration is, however, not spatially split. + !> + !> WCS 18 November 2014 + !> + !> Input: s - current model state, + !> including tendencies from sources other than resolved transport. + !> grid - grid metadata + !> + !> input scalars in state are uncoupled (i.e. not mulitplied by density) + !> + !> Output: updated uncoupled scalars (scalars in state). + !> Note: scalar tendencies are also modified by this routine. + !> + !> This routine DOES NOT apply any positive definite or monotonic renormalizations. + !> + !> The transport scheme is from Skamarock and Gassmann MWR 2011. ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in state). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES NOT apply any positive definite or monotonic renormalizations. - ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_work(nCells, num_scalars, dt, & + edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, & + uhAvg, wwAvg, dvEdge, & + cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & + scalar_tend_save, fnm, fnp, rdnw, & + bdyMaskCell, bdyMaskEdge, & + nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, & + nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & + advance_density) - use mpas_atm_dimensions + use mpas_atm_dimensions, only : nVertLevels implicit none - integer, intent(in) :: num_scalars_dummy ! for allocating stack variables integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables + integer, intent(in) :: nEdges ! for allocating stack variables + integer, intent(in) :: num_scalars real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, intent(in) :: rk_step, config_time_integration_order logical, intent(in) :: advance_density real (kind=RKIND), dimension(:,:,:), intent(in) :: scalar_old real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalar_new real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalar_tend_save - real (kind=RKIND), dimension(:,:,:), intent(in) :: deriv_two real (kind=RKIND), dimension(:,:), intent(in) :: rho_zz_old - real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_edge, zgrid, rho_zz_new, kdiff - real (kind=RKIND), dimension(:), intent(in) :: dvEdge, qv_init + real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_zz_new + real (kind=RKIND), dimension(:), intent(in) :: dvEdge integer, dimension(:,:), intent(in) :: cellsOnEdge integer, dimension(:,:), intent(in) :: advCellsForEdge, edgesOnCell integer, dimension(:), intent(in) :: nAdvCellsForEdge, nEdgesOnCell real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw real (kind=RKIND), intent(in) :: coef_3rd_order real (kind=RKIND), dimension(num_scalars,nVertLevels,nEdges+1), intent(inout) :: horiz_flux_arr - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int real (kind=RKIND), dimension(:), intent(in) :: invAreaCell - integer, intent(in) :: nCellsSolve, nEdges + integer, dimension(:), intent(in) :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 real (kind=RKIND) :: rho_zz_new_inv @@ -2785,6 +3101,10 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm logical :: local_advance_density + real (kind=RKIND) :: weight_time_old, weight_time_new + real (kind=RKIND), dimension(num_scalars,nVertLevels) :: scalar_tend_column ! local storage to accumulate tendency + real (kind=RKIND) :: u_direction, u_positive, u_negative + flux4(q_im2, q_im1, q_i, q_ip1, ua) = & ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 @@ -2797,465 +3117,260 @@ subroutine atm_advance_scalars_work( num_scalars_dummy, nCells, nVertLevels_dumm ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old ! - ! horizontal flux divergence, accumulate in scalar_tend ! horiz_flux_arr stores the value of the scalar at the edge. ! a better name perhaps would be scalarEdge + ! weights for the time interpolation of the input density + ! + if (.not. advance_density ) then + weight_time_new = 1. + else + if((rk_step == 1) .and. config_time_integration_order == 3) weight_time_new = 1./3 + if((rk_step == 1) .and. config_time_integration_order == 2) weight_time_new = 1./2 + if(rk_step == 2) weight_time_new = 1./2 + if(rk_step == 3) weight_time_new = 1. + end if + weight_time_old = 1. - weight_time_new + + + MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') + !$acc enter data create(horiz_flux_arr) + !$acc enter data copyin(uhAvg, scalar_new) + MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') + + !$acc parallel async + !$acc loop gang worker private(scalar_weight2, ica) do iEdge=edgeStart,edgeEnd - select case(nAdvCellsForEdge(iEdge)) + if ((.not.config_apply_lbcs) & + .or. (bdyMaskEdge(iEdge) < nRelaxZone-1)) then ! full flux calculation - case(10) + select case(nAdvCellsForEdge(iEdge)) - do j=1,10 -!DIR$ IVDEP - do k=1,nVertLevels - scalar_weight2(k,j) = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) + case(10) + + !$acc loop vector collapse(2) + do j=1,10 + do k=1,nVertLevels + scalar_weight2(k,j) = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) + end do end do - end do - do j=1,10 - ica(j) = advCellsForEdge(j,iEdge) - end do -!DIR$ IVDEP - do k = 1,nVertLevels -!DIR$ IVDEP - do iScalar = 1,num_scalars - horiz_flux_arr(iScalar,k,iEdge) = & - scalar_weight2(k,1) * scalar_new(iScalar,k,ica(1)) + & - scalar_weight2(k,2) * scalar_new(iScalar,k,ica(2)) + & - scalar_weight2(k,3) * scalar_new(iScalar,k,ica(3)) + & - scalar_weight2(k,4) * scalar_new(iScalar,k,ica(4)) + & - scalar_weight2(k,5) * scalar_new(iScalar,k,ica(5)) + & - scalar_weight2(k,6) * scalar_new(iScalar,k,ica(6)) + & - scalar_weight2(k,7) * scalar_new(iScalar,k,ica(7)) + & - scalar_weight2(k,8) * scalar_new(iScalar,k,ica(8)) + & - scalar_weight2(k,9) * scalar_new(iScalar,k,ica(9)) + & - scalar_weight2(k,10) * scalar_new(iScalar,k,ica(10)) + + !$acc loop vector + do j=1,10 + ica(j) = advCellsForEdge(j,iEdge) end do - end do - case default + !$acc loop vector collapse(2) + do k = 1,nVertLevels + do iScalar = 1,num_scalars + horiz_flux_arr(iScalar,k,iEdge) = & + scalar_weight2(k,1) * scalar_new(iScalar,k,ica(1)) + & + scalar_weight2(k,2) * scalar_new(iScalar,k,ica(2)) + & + scalar_weight2(k,3) * scalar_new(iScalar,k,ica(3)) + & + scalar_weight2(k,4) * scalar_new(iScalar,k,ica(4)) + & + scalar_weight2(k,5) * scalar_new(iScalar,k,ica(5)) + & + scalar_weight2(k,6) * scalar_new(iScalar,k,ica(6)) + & + scalar_weight2(k,7) * scalar_new(iScalar,k,ica(7)) + & + scalar_weight2(k,8) * scalar_new(iScalar,k,ica(8)) + & + scalar_weight2(k,9) * scalar_new(iScalar,k,ica(9)) + & + scalar_weight2(k,10) * scalar_new(iScalar,k,ica(10)) + end do + end do - horiz_flux_arr(:,:,iEdge) = 0.0 - do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) -!DIR$ IVDEP + case default + + !$acc loop vector collapse(2) do k=1,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) -!DIR$ IVDEP do iScalar=1,num_scalars - horiz_flux_arr(iScalar,k,iEdge) = horiz_flux_arr(iScalar,k,iEdge) + scalar_weight * scalar_new(iScalar,k,iAdvCell) + horiz_flux_arr(iScalar,k,iEdge) = 0.0_RKIND + end do + end do + + !$acc loop seq + do j=1,nAdvCellsForEdge(iEdge) + iAdvCell = advCellsForEdge(j,iEdge) + + !$acc loop vector collapse(2) + do k=1,nVertLevels + do iScalar=1,num_scalars + scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) + horiz_flux_arr(iScalar,k,iEdge) = horiz_flux_arr(iScalar,k,iEdge) & + + scalar_weight * scalar_new(iScalar,k,iAdvCell) + end do end do end do + end select + + else if(config_apply_lbcs & + .and. (bdyMaskEdge(iEdge) >= nRelaxZone-1) & + .and. (bdyMaskEdge(iEdge) <= nRelaxZone)) then + + ! upwind flux evaluation for outermost 2 edges in specified zone + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + !$acc loop vector collapse(2) + do k=1,nVertLevels + do iScalar=1,num_scalars + u_direction = sign(0.5_RKIND,uhAvg(k,iEdge)) + u_positive = dvEdge(iEdge)*abs(u_direction + 0.5_RKIND) + u_negative = dvEdge(iEdge)*abs(u_direction - 0.5_RKIND) + horiz_flux_arr(iScalar,k,iEdge) = u_positive*scalar_new(iScalar,k,cell1) + u_negative*scalar_new(iScalar,k,cell2) + end do end do - end select + end if ! end of regional MPAS test end do + !$acc end parallel !$OMP BARRIER - if (local_advance_density) then - if ((.not.present(scalar_tend)) .or. (.not.present(rho_zz_int))) then - call mpas_log_write('Error: rho_zz_int or scalar_tend not supplied to atm_advance_scalars( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) - end if + ! + ! scalar update, for each column sum fluxes over horizontal edges, add physics tendency, + ! and add vertical flux divergence in update. + ! - do iCell=cellSolveStart,cellSolveEnd - scalar_tend(:,:,iCell) = scalar_tend_save(:,:,iCell) + MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') #ifndef DO_PHYSICS - scalar_tend(:,:,iCell) = 0.0 ! testing purposes - we have no sources or sinks + !$acc enter data create(scalar_tend_save) +#else + !$acc enter data copyin(scalar_tend_save) #endif + !$acc enter data copyin(scalar_old, fnm, fnp, rdnw, wwAvg, rho_zz_old, rho_zz_new) + !$acc enter data create(scalar_tend_column, wdtn) + MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') + + !$acc parallel wait + !$acc loop gang worker private(scalar_tend_column, wdtn) + do iCell=cellSolveStart,cellSolveEnd - rho_zz_int(:,iCell) = 0.0 + if(bdyMaskCell(iCell) <= nRelaxZone) then ! specified zone for regional_MPAS is not updated in this routine + + !$acc loop vector collapse(2) + do k=1,nVertLevels + do iScalar=1,num_scalars + scalar_tend_column(iScalar,k) = 0.0_RKIND +#ifndef DO_PHYSICS + scalar_tend_save(iScalar,k,iCell) = 0.0_RKIND ! testing purposes - we have no sources or sinks +#endif + end do + end do + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) - + ! here we add the horizontal flux divergence into the scalar tendency. ! note that the scalar tendency is modified. -!DIR$ IVDEP + !$acc loop vector collapse(2) do k=1,nVertLevels - rho_zz_int(k,iCell) = rho_zz_int(k,iCell) - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge)*dvEdge(iEdge) * invAreaCell(iCell) -!DIR$ IVDEP do iScalar=1,num_scalars - scalar_tend(iScalar,k,iCell) = scalar_tend(iScalar,k,iCell) & - - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge)*horiz_flux_arr(iScalar,k,iEdge) * invAreaCell(iCell) + scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) & + - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge)*horiz_flux_arr(iScalar,k,iEdge) end do end do - + end do -!DIR$ IVDEP + !$acc loop vector collapse(2) do k=1,nVertLevels - rho_zz_int(k,iCell) = rho_zz_old(k,iCell) + dt*( rho_zz_int(k,iCell) - rdnw(k)*(wwAvg(k+1,iCell)-wwAvg(k,iCell)) ) + do iScalar=1,num_scalars + scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) * invAreaCell(iCell) & + + scalar_tend_save(iScalar,k,iCell) + end do end do - end do - else - do iCell=cellSolveStart,cellSolveEnd -#ifndef DO_PHYSICS - scalar_tend_save(:,:,iCell) = 0.0 ! testing purposes - we have no sources or sinks -#endif - - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - - ! here we add the horizontal flux divergence into the scalar tendency. - ! note that the scalar tendency is modified. -!DIR$ IVDEP - do k=1,nVertLevels -!DIR$ IVDEP - do iScalar=1,num_scalars - scalar_tend_save(iScalar,k,iCell) = scalar_tend_save(iScalar,k,iCell) & - - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge)*horiz_flux_arr(iScalar,k,iEdge) * invAreaCell(iCell) - end do - end do - - end do - end do - - end if - - ! - ! vertical flux divergence and update of the scalars - ! - - ! zero fluxes at top and bottom - wdtn(:,1) = 0.0 - wdtn(:,nVertLevels+1) = 0.0 - - - do iCell=cellSolveStart,cellSolveEnd - - k = 2 - do iScalar=1,num_scalars - wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) - end do - -!DIR$ IVDEP - do k=3,nVertLevels-1 -!DIR$ IVDEP - do iScalar=1,num_scalars - wdtn(iScalar,k) = flux3( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & - scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), & - wwAvg(k,iCell), coef_3rd_order ) - end do - end do - k = nVertLevels - do iScalar=1,num_scalars - wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) - end do + ! + ! vertical flux divergence and update of the scalars + ! - if (local_advance_density) then -!DIR$ IVDEP - do k=1,nVertLevels - rho_zz_new_inv = 1.0_RKIND / rho_zz_int(k,iCell) -!DIR$ IVDEP - do iScalar=1,num_scalars - scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*rho_zz_old(k,iCell) & - + dt*( scalar_tend(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) ) * rho_zz_new_inv - end do - end do - else -!DIR$ IVDEP - do k=1,nVertLevels - rho_zz_new_inv = 1.0_RKIND / rho_zz_new(k,iCell) -!DIR$ IVDEP + !$acc loop vector do iScalar=1,num_scalars - scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*rho_zz_old(k,iCell) & - + dt*( scalar_tend_save(iScalar,k,iCell) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) ) * rho_zz_new_inv - end do - end do - end if - - end do - - end subroutine atm_advance_scalars_work - - - subroutine atm_advance_scalars_work_new( num_scalars_dummy, nCells, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, scalar_old, scalar_new, rho_zz_old, rho_zz_new, kdiff, & - uhAvg, wwAvg, deriv_two, dvEdge, & - cellsOnEdge, edgesOnCell, nEdgesOnCell, edgesOnCell_sign, invAreaCell, & - scalar_tend_save, fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4, & - nAdvCellsForEdge, advCellsForEdge, adv_coefs, adv_coefs_3rd, rho_edge, qv_init, zgrid, & - nCellsSolve, nEdges, horiz_flux_arr, rk_step, config_time_integration_order, & - advance_density, scalar_tend, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - explicit transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. - ! - ! WCS 18 November 2014 - !----------------------- - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata - ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in state). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES NOT apply any positive definite or monotonic renormalizations. - ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. - ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_atm_dimensions - - implicit none - - integer, intent(in) :: num_scalars_dummy ! for allocating stack variables - integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables - real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - integer, intent(in) :: rk_step, config_time_integration_order - logical, intent(in) :: advance_density - real (kind=RKIND), dimension(:,:,:), intent(in) :: scalar_old - real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalar_new - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: scalar_tend_save - real (kind=RKIND), dimension(:,:,:), intent(in) :: deriv_two - real (kind=RKIND), dimension(:,:), intent(in) :: rho_zz_old - real (kind=RKIND), dimension(:,:), intent(in) :: uhAvg, wwAvg, rho_edge, zgrid, rho_zz_new, kdiff - real (kind=RKIND), dimension(:), intent(in) :: dvEdge, qv_init - integer, dimension(:,:), intent(in) :: cellsOnEdge - integer, dimension(:,:), intent(in) :: advCellsForEdge, edgesOnCell - integer, dimension(:), intent(in) :: nAdvCellsForEdge, nEdgesOnCell - real (kind=RKIND), dimension(:,:), intent(in) :: adv_coefs, adv_coefs_3rd, edgesOnCell_sign - real (kind=RKIND), dimension(:), intent(in) :: fnm, fnp, rdnw, meshScalingDel2, meshScalingDel4 - real (kind=RKIND), intent(in) :: coef_3rd_order - real (kind=RKIND), dimension(num_scalars,nVertLevels,nEdges+1), intent(inout) :: horiz_flux_arr - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout), optional :: scalar_tend - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int - real (kind=RKIND), dimension(:), intent(in) :: invAreaCell - integer, intent(in) :: nCellsSolve, nEdges - - integer :: i, j, iCell, iAdvCell, iEdge, k, iScalar, cell1, cell2 - real (kind=RKIND) :: rho_zz_new_inv - - real (kind=RKIND) :: scalar_weight - - real (kind=RKIND), dimension( num_scalars, nVertLevels + 1 ) :: wdtn - - real (kind=RKIND), dimension(nVertLevels,10) :: scalar_weight2 - integer, dimension(10) :: ica - - real (kind=RKIND) :: flux3, flux4 - real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 - - logical :: local_advance_density - - real (kind=RKIND) :: weight_time_old, weight_time_new - real (kind=RKIND), dimension(num_scalars,nVertLevels) :: scalar_tend_column ! local storage to accumulate tendency - - flux4(q_im2, q_im1, q_i, q_ip1, ua) = & - ua*( 7.*(q_i + q_im1) - (q_ip1 + q_im2) )/12.0 - - flux3(q_im2, q_im1, q_i, q_ip1, ua, coef3) = & - flux4(q_im2, q_im1, q_i, q_ip1, ua) + & - coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 - - local_advance_density = advance_density - - ! - ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old - ! - ! horizontal flux divergence, accumulate in scalar_tend - - - ! horiz_flux_arr stores the value of the scalar at the edge. - ! a better name perhaps would be scalarEdge - - ! weights for the time interpolation of the input density - ! - if (.not. advance_density ) then - weight_time_new = 1. - else - if((rk_step == 1) .and. config_time_integration_order == 3) weight_time_new = 1./3 - if((rk_step == 1) .and. config_time_integration_order == 2) weight_time_new = 1./2 - if(rk_step == 2) weight_time_new = 1./2 - if(rk_step == 3) weight_time_new = 1. - end if - weight_time_old = 1. - weight_time_new - - - do iEdge=edgeStart,edgeEnd - - select case(nAdvCellsForEdge(iEdge)) - - case(10) - - do j=1,10 -!DIR$ IVDEP - do k=1,nVertLevels - scalar_weight2(k,j) = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) - end do - end do - do j=1,10 - ica(j) = advCellsForEdge(j,iEdge) - end do -!DIR$ IVDEP - do k = 1,nVertLevels -!DIR$ IVDEP - do iScalar = 1,num_scalars - horiz_flux_arr(iScalar,k,iEdge) = & - scalar_weight2(k,1) * scalar_new(iScalar,k,ica(1)) + & - scalar_weight2(k,2) * scalar_new(iScalar,k,ica(2)) + & - scalar_weight2(k,3) * scalar_new(iScalar,k,ica(3)) + & - scalar_weight2(k,4) * scalar_new(iScalar,k,ica(4)) + & - scalar_weight2(k,5) * scalar_new(iScalar,k,ica(5)) + & - scalar_weight2(k,6) * scalar_new(iScalar,k,ica(6)) + & - scalar_weight2(k,7) * scalar_new(iScalar,k,ica(7)) + & - scalar_weight2(k,8) * scalar_new(iScalar,k,ica(8)) + & - scalar_weight2(k,9) * scalar_new(iScalar,k,ica(9)) + & - scalar_weight2(k,10) * scalar_new(iScalar,k,ica(10)) - end do - end do - - case default - - horiz_flux_arr(:,:,iEdge) = 0.0 - do j=1,nAdvCellsForEdge(iEdge) - iAdvCell = advCellsForEdge(j,iEdge) -!DIR$ IVDEP - do k=1,nVertLevels - scalar_weight = adv_coefs(j,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(j,iEdge) -!DIR$ IVDEP - do iScalar=1,num_scalars - horiz_flux_arr(iScalar,k,iEdge) = horiz_flux_arr(iScalar,k,iEdge) + scalar_weight * scalar_new(iScalar,k,iAdvCell) - end do - end do + wdtn(iScalar,1) = 0.0 + wdtn(iScalar,2) = wwAvg(2,iCell)*(fnm(2)*scalar_new(iScalar,2,iCell)+fnp(2)*scalar_new(iScalar,2-1,iCell)) + wdtn(iScalar,nVertLevels) = wwAvg(nVertLevels,iCell) * & + ( fnm(nVertLevels)*scalar_new(iScalar,nVertLevels,iCell) & + +fnp(nVertLevels)*scalar_new(iScalar,nVertLevels-1,iCell) ) + wdtn(iScalar,nVertLevels+1) = 0.0 end do - end select - end do - -!$OMP BARRIER - -! scalar update, for each column sum fluxes over horizontal edges, add physics tendency, and add vertical flux divergence in update. - - - do iCell=cellSolveStart,cellSolveEnd -#ifndef DO_PHYSICS - scalar_tend_save(:,:,iCell) = 0.0 ! testing purposes - we have no sources or sinks -#endif - scalar_tend_column(1:num_scalars,1:nVertlevels) = 0. - - do i=1,nEdgesOnCell(iCell) - iEdge = edgesOnCell(i,iCell) - - ! here we add the horizontal flux divergence into the scalar tendency. - ! note that the scalar tendency is modified. -!DIR$ IVDEP - do k=1,nVertLevels -!DIR$ IVDEP - do iScalar=1,num_scalars - scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) & - - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge)*horiz_flux_arr(iScalar,k,iEdge) - end do + !$acc loop vector collapse(2) + do k=3,nVertLevels-1 + do iScalar=1,num_scalars + wdtn(iScalar,k) = flux3( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & + scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), & + wwAvg(k,iCell), coef_3rd_order ) end do - end do -!DIR$ IVDEP + !$acc loop vector collapse(2) do k=1,nVertLevels -!DIR$ IVDEP do iScalar=1,num_scalars - scalar_tend_column(iScalar,k) = scalar_tend_column(iScalar,k) * invAreaCell(iCell) + scalar_tend_save(iScalar,k,iCell) + rho_zz_new_inv = 1.0_RKIND / (weight_time_old*rho_zz_old(k,iCell) + weight_time_new*rho_zz_new(k,iCell)) + scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*rho_zz_old(k,iCell) & + + dt*( scalar_tend_column(iScalar,k) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) ) * rho_zz_new_inv end do end do - - - ! - ! vertical flux divergence and update of the scalars - ! - wdtn(:,1) = 0.0 - wdtn(:,nVertLevels+1) = 0.0 - - k = 2 - do iScalar=1,num_scalars - wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) - end do - -!DIR$ IVDEP - do k=3,nVertLevels-1 -!DIR$ IVDEP - do iScalar=1,num_scalars - wdtn(iScalar,k) = flux3( scalar_new(iScalar,k-2,iCell),scalar_new(iScalar,k-1,iCell), & - scalar_new(iScalar,k ,iCell),scalar_new(iScalar,k+1,iCell), & - wwAvg(k,iCell), coef_3rd_order ) - end do - end do - k = nVertLevels - do iScalar=1,num_scalars - wdtn(iScalar,k) = wwAvg(k,iCell)*(fnm(k)*scalar_new(iScalar,k,iCell)+fnp(k)*scalar_new(iScalar,k-1,iCell)) - end do -!DIR$ IVDEP - do k=1,nVertLevels - rho_zz_new_inv = 1.0_RKIND / (weight_time_old*rho_zz_old(k,iCell) + weight_time_new*rho_zz_new(k,iCell)) -!DIR$ IVDEP - do iScalar=1,num_scalars - scalar_new(iScalar,k,iCell) = ( scalar_old(iScalar,k,iCell)*rho_zz_old(k,iCell) & - + dt*( scalar_tend_column(iScalar,k) -rdnw(k)*(wdtn(iScalar,k+1)-wdtn(iScalar,k)) ) ) * rho_zz_new_inv - end do - end do + end if ! specified zone regional_MPAS test end do + !$acc end parallel - end subroutine atm_advance_scalars_work_new + MPAS_ACC_TIMER_START('atm_advance_scalars [ACC_data_xfer]') + !$acc exit data copyout(scalar_new) + !$acc exit data delete(scalar_tend_column, wdtn, uhAvg, wwAvg, scalar_old, fnm, fnp, & + !$acc rdnw, rho_zz_old, rho_zz_new, horiz_flux_arr, scalar_tend_save) + MPAS_ACC_TIMER_STOP('atm_advance_scalars [ACC_data_xfer]') + end subroutine atm_advance_scalars_work - subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCells, nEdges, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - scalar_old, scalar_new, s_max, s_min, wdtn, scale_arr, flux_arr, & - flux_upwind_tmp, flux_tmp, advance_density, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - transport plus other tendencies + + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_mono ! - ! wrapper routine for atm_advance_scalars_mono_work + !> \brief Integrate scalar equations - transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This routine is a wrapper for atm_advance_scalars_mono_work and is primarily + !> intended to allow pointers to fields to be dereferenced through the call + !> to the work routine. ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - use mpas_atm_dimensions + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_mono(field_name, block, tend, state, diag, mesh, halo_scratch, configs, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + scalar_old, scalar_new, s_max, s_min, wdtn, flux_arr, & + flux_upwind_tmp, flux_tmp, exchange_halo_group, advance_density, rho_zz_int) implicit none + ! Arguments + character(len=*), intent(in) :: field_name type (block_type), intent(inout), target :: block type (mpas_pool_type), intent(in) :: tend type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: halo_scratch type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: nCells ! for allocating stack variables - integer, intent(in) :: nEdges ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min - real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn - real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout) :: scale_arr - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_arr - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_upwind_tmp, flux_tmp + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + real (kind=RKIND), dimension(:,:), intent(inout) :: scalar_old, scalar_new + real (kind=RKIND), dimension(:,:), intent(inout) :: s_max, s_min + real (kind=RKIND), dimension(:,:), intent(inout) :: wdtn + real (kind=RKIND), dimension(:,:), intent(inout) :: flux_arr + real (kind=RKIND), dimension(:,:), intent(inout) :: flux_upwind_tmp, flux_tmp + procedure (halo_exchange_routine) :: exchange_halo_group logical, intent(in), optional :: advance_density - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int + real (kind=RKIND), dimension(:,:), intent(inout), optional :: rho_zz_int + ! Local variables real (kind=RKIND), dimension(:,:,:), pointer :: scalar_tend real (kind=RKIND), dimension(:,:), pointer :: uhAvg, rho_zz_old, rho_zz_new, wwAvg real (kind=RKIND), dimension(:), pointer :: dvEdge, invAreaCell @@ -3267,25 +3382,37 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe real (kind=RKIND), dimension(:,:), pointer :: adv_coefs, adv_coefs_3rd real (kind=RKIND), dimension(:,:,:), pointer :: scalars_old, scalars_new + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge ! regional_MPAS addition + + integer, pointer :: nCells + integer, pointer :: nEdges integer, pointer :: nCellsSolve + integer, pointer :: num_scalars real (kind=RKIND), dimension(:), pointer :: fnm, fnp, rdnw integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), pointer :: coef_3rd_order + type (field3DReal), pointer :: scale + real (kind=RKIND), dimension(:,:,:), pointer :: scale_arr + + call mpas_pool_get_config(configs, 'config_coef_3rd_order', coef_3rd_order) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'num_'//trim(field_name), num_scalars) call mpas_pool_get_array(diag, 'ruAvg', uhAvg) call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(tend, 'scalars_tend', scalar_tend) + call mpas_pool_get_array(tend, trim(field_name)//'_tend', scalar_tend) call mpas_pool_get_array(state, 'rho_zz', rho_zz_old, 1) call mpas_pool_get_array(state, 'rho_zz', rho_zz_new, 2) - call mpas_pool_get_array(state, 'scalars', scalars_old, 1) - call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + call mpas_pool_get_array(state, trim(field_name), scalars_old, 1) + call mpas_pool_get_array(state, trim(field_name), scalars_new, 2) call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) @@ -3302,69 +3429,86 @@ subroutine atm_advance_scalars_mono(block, tend, state, diag, mesh, configs, nCe call mpas_pool_get_array(mesh, 'adv_coefs', adv_coefs) call mpas_pool_get_array(mesh, 'adv_coefs_3rd', adv_coefs_3rd) - call atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, nCellsSolve, num_scalars, uhAvg, wwAvg, scalar_tend, rho_zz_old, & + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) ! MPAS_regional addition + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) ! MPAS_regional addition + + call mpas_pool_get_field(halo_scratch, 'scale', scale) + call mpas_allocate_scratch_field(scale) + call mpas_pool_get_array(halo_scratch, 'scale', scale_arr) + + call atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdges, num_scalars, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & - advance_density, rho_zz_int) + bdyMaskCell, bdyMaskEdge, & + exchange_halo_group, advance_density, rho_zz_int) + + call mpas_deallocate_scratch_field(scale) end subroutine atm_advance_scalars_mono - subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLevels_dummy, dt, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd, & - coef_3rd_order, nCellsSolve, num_scalars_dummy, uhAvg, wwAvg, scalar_tend, rho_zz_old, & + !----------------------------------------------------------------------- + ! routine atm_advance_scalars_mono_work + ! + !> \brief Integrate scalar equations - transport plus other tendencies + !> \date 18 November 2014 + !> \details + !> This transport routine is similar to the original atm_advance_scalars_mono_work, + !> except it also advances (re-integrates) the density. This re-integration allows + !> the scalar transport routine to use a different timestep than the dry dynamics, + !> and also makes possible a spatial splitting of the scalar transport integration + !> (and density integration). The current integration is, however, not spatially split. + !> + !> WCS 18 November 2014 + !> + !> + !> Input: s - current model state, + !> including tendencies from sources other than resolved transport. + !> grid - grid metadata + !> + !> input scalars in state are uncoupled (i.e. not mulitplied by density) + !> + !> Output: updated uncoupled scalars (scalars in s_new). + !> Note: scalar tendencies are also modified by this routine. + !> + !> This routine DOES apply positive definite or monotonic renormalizations. + !> + !> The transport scheme is from Skamarock and Gassmann MWR 2011. + !> + !> The positive-definite or monotonic renormalization is from Zalesak JCP 1979 + !> as used in the RK3 scheme as described in Wang et al MWR 2009 + ! + !----------------------------------------------------------------------- + subroutine atm_advance_scalars_mono_work(field_name, block, state, nCells, nEdges, num_scalars, dt, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, & + coef_3rd_order, nCellsSolve, uhAvg, wwAvg, scalar_tend, rho_zz_old, & rho_zz_new, scalars_old, scalars_new, invAreaCell, dvEdge, cellsOnEdge, cellsOnCell, & edgesOnCell, edgesOnCell_sign, nEdgesOnCell, fnm, fnp, rdnw, nAdvCellsForEdge, & advCellsForEdge, adv_coefs, adv_coefs_3rd, scalar_old, scalar_new, s_max, s_min, & wdtn, scale_arr, flux_arr, flux_upwind_tmp, flux_tmp, & - advance_density, rho_zz_int) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Integrate scalar equations - transport plus other tendencies - ! - ! this transport routine is similar to the original atm_advance_scalars_mono_work, except it also advances - ! (re-integrates) the density. This re-integration allows the scalar transport routine to use a different - ! timestep than the dry dynamics, and also makes possible a spatial splitting of the scalar transport integration - ! (and density integration). The current integration is, however, not spatially split. - ! - ! WCS 18 November 2014 - !----------------------- - ! - ! Input: s - current model state, - ! including tendencies from sources other than resolved transport. - ! grid - grid metadata - ! - ! input scalars in state are uncoupled (i.e. not mulitplied by density) - ! - ! Output: updated uncoupled scalars (scalars in s_new). - ! Note: scalar tendencies are also modified by this routine. - ! - ! This routine DOES apply positive definite or monotonic renormalizations. - ! - ! The transport scheme is from Skamarock and Gassmann MWR 2011. - ! - ! The positive-definite or monotonic renormalization is from Zalesak JCP 1979 - ! as used in the RK3 scheme as described in Wang et al MWR 2009 - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + bdyMaskCell, bdyMaskEdge, & + exchange_halo_group, advance_density, rho_zz_int) - use mpas_atm_dimensions + use mpas_atm_dimensions, only : nVertLevels implicit none + character(len=*), intent(in) :: field_name type (block_type), intent(inout), target :: block type (mpas_pool_type), intent(inout) :: state integer, intent(in) :: nCells ! for allocating stack variables integer, intent(in) :: nEdges ! for allocating stack variables - integer, intent(in) :: nVertLevels_dummy ! for allocating stack variables + integer, intent(in) :: num_scalars real (kind=RKIND), intent(in) :: dt - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + procedure (halo_exchange_routine) :: exchange_halo_group logical, intent(in), optional :: advance_density real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout), optional :: rho_zz_int @@ -3381,6 +3525,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(in) :: wwAvg real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invAreaCell integer, dimension(:,:), intent(in) :: cellsOnEdge, cellsOnCell, edgesOnCell + integer, dimension(:) :: bdyMaskCell, bdyMaskEdge real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign integer, dimension(:,:), intent(in) :: advCellsForEdge @@ -3390,19 +3535,16 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: scalar_old, scalar_new real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: s_max, s_min real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: wdtn - real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout), target :: scale_arr + real (kind=RKIND), dimension(nVertLevels,2,nCells+1), intent(inout) :: scale_arr real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_arr real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: flux_upwind_tmp, flux_tmp - type (field3DReal), pointer :: scalars_old_field - - type (field3DReal), pointer :: tempField - type (field3DReal), target :: tempFieldTarget - integer, parameter :: SCALE_IN = 1, SCALE_OUT = 2 - integer, intent(in) :: nCellsSolve, num_scalars_dummy + integer, intent(in) :: nCellsSolve +#ifdef DEBUG_TRANSPORT integer :: icellmax, kmax +#endif real (kind=RKIND), dimension(nVertLevels), intent(in) :: fnm, fnp, rdnw integer, dimension(:), intent(in) :: nEdgesOnCell @@ -3411,7 +3553,10 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve real (kind=RKIND), dimension(nVertLevels) :: flux_upwind_arr real (kind=RKIND) :: flux3, flux4, flux_upwind - real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3, scmin,scmax + real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 +#ifdef DEBUG_TRANSPORT + real (kind=RKIND) :: scmin,scmax +#endif real (kind=RKIND) :: scale_factor logical :: local_advance_density @@ -3431,37 +3576,65 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve local_advance_density = .true. end if - call mpas_pool_get_field(state, 'scalars', scalars_old_field, 1) - ! for positive-definite or monotonic option, we first update scalars using the tendency from sources other than ! the resolved transport (these should constitute a positive definite update). ! Note, however, that we enforce positive-definiteness in this update. ! The transport will maintain this positive definite solution and optionally, shape preservation (monotonicity). + + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc data present(nEdgesOnCell, edgesOnCell, edgesOnCell_sign, & + !$acc invAreaCell, cellsOnCell, cellsOnEdge, nAdvCellsForEdge, & + !$acc advCellsForEdge, adv_coefs, adv_coefs_3rd, dvEdge, bdyMaskCell) + +#ifdef DO_PHYSICS + !$acc enter data copyin(scalar_tend) +#else + !$acc enter data create(scalar_tend) +#endif + if (local_advance_density) then + !$acc enter data copyin(rho_zz_int) + end if + !$acc enter data copyin(scalars_old, rho_zz_old, rdnw, uhAvg, wwAvg) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + + !$acc parallel + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k = 1,nVertLevels -!DIR$ IVDEP - do iScalar = 1,num_scalars + + !$acc loop vector collapse(2) + do k = 1,nVertLevels + do iScalar = 1,num_scalars #ifndef DO_PHYSICS -!TBH: Michael, would you please check this change? Our test uses -DDO_PHYSICS -!TBH: so this code is not executed. The change avoids redundant work. - scalar_tend(iScalar,k,iCell) = 0.0 ! testing purposes - we have no sources or sinks + scalar_tend(iScalar,k,iCell) = 0.0_RKIND ! testing purposes - we have no sources or sinks #endif - scalars_old(iScalar,k,iCell) = scalars_old(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / rho_zz_old(k,iCell) - scalar_tend(iScalar,k,iCell) = 0.0 - end do + scalars_old(iScalar,k,iCell) = scalars_old(iScalar,k,iCell)+dt*scalar_tend(iScalar,k,iCell) / rho_zz_old(k,iCell) + scalar_tend(iScalar,k,iCell) = 0.0_RKIND + end do end do + end do + !$acc end parallel + + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc exit data copyout(scalar_tend) + + !$acc update self(scalars_old) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') !$OMP BARRIER !$OMP MASTER - call mpas_dmpar_exch_halo_field(scalars_old_field) + call exchange_halo_group(block % domain, 'dynamics:'//trim(field_name)//'_old') !$OMP END MASTER !$OMP BARRIER + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update device(scalars_old) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + ! ! Runge Kutta integration, so we compute fluxes from scalar_new values, update starts from scalar_old ! @@ -3471,46 +3644,83 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve call mpas_log_write('Error: rho_zz_int not supplied to atm_advance_scalars_mono_work( ) when advance_density=.true.', messageType=MPAS_LOG_CRIT) end if + !$acc parallel + ! begin with update of density - do iCell=cellStart,cellEnd - rho_zz_int(:,iCell) = 0.0 - end do -!$OMP BARRIER + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd + + !$acc loop vector + do k=1,nVertLevels + rho_zz_int(k,iCell) = 0.0_RKIND + end do + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) -!DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels - rho_zz_int(k,iCell) = rho_zz_int(k,iCell) - edgesOnCell_sign(i,iCell) * uhAvg(k,iEdge) * dvEdge(iEdge) * invAreaCell(iCell) + rho_zz_int(k,iCell) = rho_zz_int(k,iCell) - edgesOnCell_sign(i,iCell) & + * uhAvg(k,iEdge) * dvEdge(iEdge) * invAreaCell(iCell) end do end do end do + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels - rho_zz_int(k,iCell) = rho_zz_old(k,iCell) + dt*( rho_zz_int(k,iCell) - rdnw(k)*(wwAvg(k+1,iCell)-wwAvg(k,iCell)) ) + rho_zz_int(k,iCell) = rho_zz_old(k,iCell) + dt*(rho_zz_int(k,iCell) - rdnw(k)*(wwAvg(k+1,iCell)-wwAvg(k,iCell))) end do end do + + !$acc end parallel + !$OMP BARRIER + end if - ! next, do one scalar at a time + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + if (.not. local_advance_density) then + !$acc enter data copyin(rho_zz_new) + end if + !$acc enter data copyin(scalars_new, fnm, fnp) + !$acc enter data create(scalar_old, scalar_new, scale_arr, s_min, s_max, & + !$acc flux_arr, flux_tmp, flux_upwind_tmp, wdtn) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') do iScalar = 1, num_scalars + !$acc parallel + + !$acc loop gang worker do iCell=cellStart,cellEnd -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels scalar_old(k,iCell) = scalars_old(iScalar,k,iCell) scalar_new(k,iCell) = scalars_new(iScalar,k,iCell) end do end do +#ifndef MPAS_OPENACC + do k=1,nVertLevels + scalar_old(k,nCells+1) = 0.0_RKIND + scalar_new(k,nCells+1) = 0.0_RKIND + end do +#endif + + !$acc end parallel + !$OMP BARRIER #ifdef DEBUG_TRANSPORT + !$acc update self(scalar_old) + scmin = scalar_old(1,1) scmax = scalar_old(1,1) do iCell = 1, nCells @@ -3521,6 +3731,8 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do call mpas_log_write(' scmin, scmin old in $r $r', realArgs=(/scmin,scmax/)) + !$acc update self(scalar_new) + scmin = scalar_new(1,1) scmax = scalar_new(1,1) do iCell = 1, nCells @@ -3532,15 +3744,17 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve call mpas_log_write(' scmin, scmin new in ', realArgs=(/scmin,scmax/)) #endif + !$acc parallel ! ! vertical flux divergence, and min and max bounds for flux limiter ! + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd ! zero flux at top and bottom - wdtn(1,iCell) = 0.0 - wdtn(nVertLevels+1,iCell) = 0.0 + wdtn(1,iCell) = 0.0_RKIND + wdtn(nVertLevels+1,iCell) = 0.0_RKIND k = 1 s_max(k,iCell) = max(scalar_old(1,iCell),scalar_old(2,iCell)) @@ -3551,7 +3765,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve s_max(k,iCell) = max(scalar_old(k-1,iCell),scalar_old(k,iCell),scalar_old(k+1,iCell)) s_min(k,iCell) = min(scalar_old(k-1,iCell),scalar_old(k,iCell),scalar_old(k+1,iCell)) -!DIR$ IVDEP + !$acc loop vector do k=3,nVertLevels-1 wdtn(k,iCell) = flux3( scalar_new(k-2,iCell),scalar_new(k-1,iCell), & scalar_new(k ,iCell),scalar_new(k+1,iCell), & @@ -3573,7 +3787,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! original code retained in select "default" case select case(nEdgesOnCell(iCell)) case(6) -!DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels s_max(k,iCell) = max(s_max(k,iCell), & scalar_old(k, cellsOnCell(1,iCell)), & @@ -3589,11 +3803,13 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve scalar_old(k, cellsOnCell(4,iCell)), & scalar_old(k, cellsOnCell(5,iCell)), & scalar_old(k, cellsOnCell(6,iCell))) - enddo + end do case default + !$acc loop seq do i=1, nEdgesOnCell(iCell) -!DIR$ IVDEP + + !$acc loop vector do k=1, nVertLevels s_max(k,iCell) = max(s_max(k,iCell),scalar_old(k, cellsOnCell(i,iCell))) s_min(k,iCell) = min(s_min(k,iCell),scalar_old(k, cellsOnCell(i,iCell))) @@ -3603,12 +3819,16 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do + !$acc end parallel + !$OMP BARRIER + !$acc parallel + ! ! horizontal flux divergence ! - + !$acc loop gang worker private(ica, swa) do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) @@ -3621,11 +3841,14 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! be sure to see additional declarations near top of subroutine select case(nAdvCellsForEdge(iEdge)) case(10) + !$acc loop vector do jj=1,10 ica(jj) = advCellsForEdge(jj,iEdge) swa(jj,1) = adv_coefs(jj,iEdge) + adv_coefs_3rd(jj,iEdge) swa(jj,2) = adv_coefs(jj,iEdge) - adv_coefs_3rd(jj,iEdge) - enddo + end do + + !$acc loop vector do k=1,nVertLevels ii = merge(1, 2, uhAvg(k,iEdge) > 0) flux_arr(k,iEdge) = uhAvg(k,iEdge)*( & @@ -3634,15 +3857,19 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve swa(5,ii)*scalar_new(k,ica(5)) + swa(6,ii)*scalar_new(k,ica(6)) + & swa(7,ii)*scalar_new(k,ica(7)) + swa(8,ii)*scalar_new(k,ica(8)) + & swa(9,ii)*scalar_new(k,ica(9)) + swa(10,ii)*scalar_new(k,ica(10))) - enddo + end do case default + !$acc loop vector do k=1,nVertLevels flux_arr(k,iEdge) = 0.0_RKIND - enddo + end do + + !$acc loop seq do i=1,nAdvCellsForEdge(iEdge) iCell = advCellsForEdge(i,iEdge) -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels scalar_weight = uhAvg(k,iEdge)*(adv_coefs(i,iEdge) + sign(1.0_RKIND,uhAvg(k,iEdge))*adv_coefs_3rd(i,iEdge)) flux_arr(k,iEdge) = flux_arr(k,iEdge) + scalar_weight* scalar_new(k,iCell) @@ -3651,43 +3878,55 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end select else - flux_arr(:,iEdge) = 0.0_RKIND + + !$acc loop vector + do k=1,nVertLevels + flux_arr(k,iEdge) = 0.0_RKIND + end do + end if end do + !$acc end parallel + !$OMP BARRIER + !$acc parallel + ! ! vertical flux divergence for upwind update, we will put upwind update into scalar_new, and put factor of dt in fluxes ! + !$acc loop gang worker private(flux_upwind_arr) do iCell=cellSolveStart,cellSolveEnd k = 1 scalar_new(k,iCell) = scalar_old(k,iCell) * rho_zz_old(k,iCell) -!DIR$ IVDEP + !$acc loop vector do k = 2, nVertLevels scalar_new(k,iCell) = scalar_old(k,iCell)*rho_zz_old(k,iCell) flux_upwind_arr(k) = dt*(max(0.0_RKIND,wwAvg(k,iCell))*scalar_old(k-1,iCell) + min(0.0_RKIND,wwAvg(k,iCell))*scalar_old(k,iCell)) end do + + !$acc loop vector do k = 1, nVertLevels-1 scalar_new(k,iCell) = scalar_new(k,iCell) - flux_upwind_arr(k+1)*rdnw(k) end do -!DIR$ IVDEP + + !$acc loop vector do k = 2, nVertLevels scalar_new(k ,iCell) = scalar_new(k ,iCell) + flux_upwind_arr(k)*rdnw(k) wdtn(k,iCell) = dt*wdtn(k,iCell) - flux_upwind_arr(k) end do - ! ! scale_arr(SCALE_IN,:,:) and scale_arr(SCALE_OUT:,:) are used here to store the incoming and outgoing perturbation flux ! contributions to the update: first the vertical flux component, then the horizontal ! -!DIR$ IVDEP + !$acc loop vector do k=1,nVertLevels scale_arr(k,SCALE_IN, iCell) = - rdnw(k)*(min(0.0_RKIND,wdtn(k+1,iCell))-max(0.0_RKIND,wdtn(k,iCell))) scale_arr(k,SCALE_OUT,iCell) = - rdnw(k)*(max(0.0_RKIND,wdtn(k+1,iCell))-min(0.0_RKIND,wdtn(k,iCell))) @@ -3700,22 +3939,43 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! ! upwind flux computation + !$acc loop gang worker do iEdge=edgeStart,edgeEnd + cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) -!DIR$ IVDEP - do k=1, nVertLevels + + !$acc loop vector + do k=1,nVertLevels flux_upwind_tmp(k,iEdge) = dvEdge(iEdge) * dt * & (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) flux_tmp(k,iEdge) = dt * flux_arr(k,iEdge) - flux_upwind_tmp(k,iEdge) end do + + if( config_apply_lbcs .and. (bdyMaskEdge(iEdge) == nRelaxZone) .or. (bdyMaskEdge(iEdge) == nRelaxZone-1) ) then + !$acc loop vector + do k=1,nVertLevels + flux_tmp(k,iEdge) = 0.0_RKIND + flux_arr(k,iEdge) = flux_upwind_tmp(k,iEdge) + end do + end if + end do + + !$acc end parallel + !$OMP BARRIER + + !$acc parallel + + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) -!DIR$ IVDEP + !$acc loop vector do k=1, nVertLevels scalar_new(k,iCell) = scalar_new(k,iCell) - edgesOnCell_sign(i,iCell) * flux_upwind_tmp(k,iEdge) * invAreaCell(iCell) @@ -3728,6 +3988,7 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end do + ! ! next, the limiter ! @@ -3735,70 +3996,82 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! simplification of limiter calculations ! worked through algebra and found equivalent form ! added benefit that it should address ifort single prec overflow issue - if (local_advance_density) then - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k = 1, nVertLevels + if (local_advance_density) then + !$acc loop gang worker + do iCell=cellSolveStart,cellSolveEnd - scale_factor = (s_max(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_IN,iCell) + eps) - scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + !$acc loop vector + do k = 1, nVertLevels + scale_factor = (s_max(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_IN,iCell) + eps) + scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) - scale_factor = (s_min(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_OUT,iCell) - eps) - scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + scale_factor = (s_min(k,iCell)*rho_zz_int(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_OUT,iCell) - eps) + scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + end do end do - end do - else - do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP - do k = 1, nVertLevels + else + !$acc loop gang worker + do iCell=cellSolveStart,cellSolveEnd - scale_factor = (s_max(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_IN,iCell) + eps) - scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + !$acc loop vector + do k = 1, nVertLevels + scale_factor = (s_max(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_IN,iCell) + eps) + scale_arr(k,SCALE_IN,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) - scale_factor = (s_min(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & - (scale_arr(k,SCALE_OUT,iCell) - eps) - scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + scale_factor = (s_min(k,iCell)*rho_zz_new(k,iCell) - scalar_new(k,iCell)) / & + (scale_arr(k,SCALE_OUT,iCell) - eps) + scale_arr(k,SCALE_OUT,iCell) = min( 1.0_RKIND, max( 0.0_RKIND, scale_factor) ) + end do end do - end do - end if + end if + + !$acc end parallel ! ! communicate scale factors here. ! communicate only first halo row in these next two exchanges ! + + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update self(scale_arr) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + !$OMP BARRIER !$OMP MASTER - tempField => tempFieldTarget - - tempField % block => block - tempField % dimSizes(1) = nVertLevels - tempField % dimSizes(2) = 2 - tempField % dimSizes(3) = nCells - tempField % sendList => block % parinfo % cellsToSend - tempField % recvList => block % parinfo % cellsToRecv - tempField % copyList => block % parinfo % cellsToCopy - tempField % prev => null() - tempField % next => null() - tempField % isActive = .true. - - tempField % array => scale_arr - call mpas_dmpar_exch_halo_field(tempField, (/ 1 /)) + call exchange_halo_group(block % domain, 'dynamics:scale') !$OMP END MASTER !$OMP BARRIER + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + !$acc update device(scale_arr) + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + + !$acc parallel + + !$acc loop gang worker do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then ! only for owned cells -!DIR$ IVDEP + + !$acc loop vector do k=1, nVertLevels flux_upwind = dvEdge(iEdge) * dt * & (max(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell1) + min(0.0_RKIND,uhAvg(k,iEdge))*scalar_old(k,cell2)) flux_arr(k,iEdge) = dt*flux_arr(k,iEdge) - flux_upwind end do + + if( config_apply_lbcs .and. (bdyMaskEdge(iEdge) == nRelaxZone) .or. (bdyMaskEdge(iEdge) == nRelaxZone-1) ) then + !$acc loop vector + do k=1,nVertLevels + flux_arr(k,iEdge) = 0.0_RKIND + end do + end if + end if end do @@ -3808,11 +4081,14 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! moved assignment to scalar_new from separate loop (see commented code below) ! into the following loops. Avoids having to save elements of flux array + !$acc loop gang worker do iEdge=edgeStart,edgeEnd cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then -!DIR$ IVDEP + + !$acc loop vector do k = 1, nVertLevels flux = flux_arr(k,iEdge) flux = max(0.0_RKIND,flux) * min(scale_arr(k,SCALE_OUT,cell1), scale_arr(k,SCALE_IN, cell2)) & @@ -3821,14 +4097,21 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end if end do - - ! - ! rescale the vertical flux - ! + + !$acc end parallel + + ! + ! rescale the vertical flux + ! + !$OMP BARRIER + + !$acc parallel + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd -!DIR$ IVDEP + + !$acc loop vector do k = 2, nVertLevels flux = wdtn(k,iCell) flux = max(0.0_RKIND,flux) * min(scale_arr(k-1,SCALE_OUT,iCell), scale_arr(k ,SCALE_IN,iCell)) & @@ -3837,33 +4120,42 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve end do end do - ! ! do the scalar update now that we have the fluxes ! + !$acc loop gang worker do iCell=cellSolveStart,cellSolveEnd + + !$acc loop seq do i=1,nEdgesOnCell(iCell) iEdge = edgesOnCell(i,iCell) -!DIR$ IVDEP + + !$acc loop vector do k=1,nVertLevels scalar_new(k,iCell) = scalar_new(k,iCell) - edgesOnCell_sign(i,iCell)*flux_arr(k,iEdge) * invAreaCell(iCell) end do end do - if (local_advance_density) then -!DIR$ IVDEP - do k=1,nVertLevels - scalar_new(k,iCell) = ( scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_int(k,iCell) - end do - else -!DIR$ IVDEP - do k=1,nVertLevels - scalar_new(k,iCell) = ( scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_new(k,iCell) - end do - end if + if (local_advance_density) then + !$acc loop vector + do k=1,nVertLevels + scalar_new(k,iCell) = (scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_int(k,iCell) + end do + else + !$acc loop vector + do k=1,nVertLevels + scalar_new(k,iCell) = (scalar_new(k,iCell) + (-rdnw(k)*(wdtn(k+1,iCell)-wdtn(k,iCell)) ) )/rho_zz_new(k,iCell) + end do + end if end do + !$acc end parallel + #ifdef DEBUG_TRANSPORT + !$acc update self(scalar_new) + !$acc update self(s_max) + !$acc update self(s_min) + scmin = scalar_new(1,1) scmax = scalar_new(1,1) do iCell = 1, nCellsSolve @@ -3886,14 +4178,36 @@ subroutine atm_advance_scalars_mono_work(block, state, nCells, nEdges, nVertLeve ! hence the enforcement of PD in the copy back to the model state. !$OMP BARRIER + !$acc parallel + + !$acc loop gang worker do iCell=cellStart,cellEnd - do k=1, nVertLevels - scalars_new(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) - end do + if(bdyMaskCell(iCell) <= nSpecZone) then ! regional_MPAS does spec zone update after transport. + !$acc loop vector + do k=1,nVertLevels + scalars_new(iScalar,k,iCell) = max(0.0_RKIND,scalar_new(k,iCell)) + end do + end if end do + !$acc end parallel + end do ! loop over scalars + MPAS_ACC_TIMER_START('atm_advance_scalars_mono [ACC_data_xfer]') + if (local_advance_density) then + !$acc exit data copyout(rho_zz_int) + else + !$acc exit data delete(rho_zz_new) + end if + !$acc exit data copyout(scalars_new) + !$acc exit data delete(scalars_old, scalar_old, scalar_new, scale_arr, s_min, s_max, & + !$acc rho_zz_old, flux_arr, flux_tmp, flux_upwind_tmp, wdtn, wwAvg, & + !$acc uhAvg, fnm, fnp, rdnw) + + !$acc end data + MPAS_ACC_TIMER_STOP('atm_advance_scalars_mono [ACC_data_xfer]') + end subroutine atm_advance_scalars_mono_work @@ -3919,7 +4233,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, ! Dummy arguments ! type (mpas_pool_type), intent(inout) :: tend - type (mpas_pool_type), intent(inout) :: tend_physics + type (mpas_pool_type), pointer :: tend_physics type (mpas_pool_type), intent(in) :: state type (mpas_pool_type), intent(in) :: diag type (mpas_pool_type), intent(in) :: mesh @@ -3949,9 +4263,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:), pointer :: rr_save - - real (kind=RKIND), dimension(:,:), pointer :: tend_rtheta_adv ! needed for Tiedtke convection scheme - real (kind=RKIND), dimension(:,:), pointer :: rthdynten ! needed for Grell-Freitas convection scheme + real (kind=RKIND), dimension(:,:), pointer :: rthdynten real (kind=RKIND), dimension(:,:,:), pointer :: scalars @@ -3960,7 +4272,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex integer, dimension(:), pointer :: nEdgesOnCell, nEdgesOnEdge - real (kind=RKIND), dimension(:), pointer :: latCell, latEdge, angleEdge, u_init + real (kind=RKIND), dimension(:), pointer :: latCell, latEdge, angleEdge, u_init, v_init integer, dimension(:,:), pointer :: advCellsForEdge integer, dimension(:), pointer :: nAdvCellsForEdge @@ -3989,7 +4301,10 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, real (kind=RKIND), pointer :: config_h_mom_eddy_visc2, config_v_mom_eddy_visc2 real (kind=RKIND), pointer :: config_h_theta_eddy_visc2, config_v_theta_eddy_visc2 - logical :: inactive_rthdynten + real (kind=RKIND), pointer :: config_mpas_cam_coef + logical, pointer :: config_rayleigh_damp_u + real (kind=RKIND), pointer :: config_rayleigh_damp_u_timescale_days + integer, pointer :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels call mpas_pool_get_config(mesh, 'sphere_radius', r_earth) @@ -4006,6 +4321,11 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_config(configs, 'config_visc4_2dsmag', config_visc4_2dsmag) call mpas_pool_get_config(configs, 'config_len_disp', config_len_disp) call mpas_pool_get_config(configs, 'config_smagorinsky_coef', c_s) + call mpas_pool_get_config(configs, 'config_mpas_cam_coef', config_mpas_cam_coef) + call mpas_pool_get_config(configs, 'config_rayleigh_damp_u', config_rayleigh_damp_u) + call mpas_pool_get_config(configs, 'config_rayleigh_damp_u_timescale_days', config_rayleigh_damp_u_timescale_days) + call mpas_pool_get_config(configs, 'config_number_rayleigh_damp_u_levels', config_number_rayleigh_damp_u_levels) + call mpas_pool_get_config(configs, 'config_number_cam_damping_levels', config_number_cam_damping_levels) call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) call mpas_pool_get_array(state, 'u', u, 2) @@ -4035,7 +4355,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(diag, 'h_divergence', h_divergence) call mpas_pool_get_array(diag, 'exner', exner) - call mpas_pool_get_array(diag, 'tend_rtheta_adv', tend_rtheta_adv) call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) @@ -4066,6 +4385,7 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'v_init', v_init) call mpas_pool_get_array(mesh, 't_init', t_init) call mpas_pool_get_array(mesh, 'qv_init', qv_init) @@ -4112,18 +4432,6 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, call mpas_pool_get_array(mesh, 'cf2', cf2) call mpas_pool_get_array(mesh, 'cf3', cf3) - ! - ! rthdynten is currently associated with packages, and if those packages - ! are not active at run-time, we need to produce an rthdynten array for - ! use in the atm_compute_dyn_tend_work routine - ! - inactive_rthdynten = .false. - if (.not. associated(rthdynten)) then - allocate(rthdynten(nVertLevels,nCells+1)) - rthdynten(:,nCells+1) = 0.0_RKIND - inactive_rthdynten = .true. - end if - call atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels, & nCellsSolve, nEdgesSolve, vertexDegree, maxEdges, maxEdges2, num_scalars, moist_start, moist_end, & fEdge, dvEdge, dcEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle, meshScalingDel2, meshScalingDel4, & @@ -4133,19 +4441,18 @@ subroutine atm_compute_dyn_tend(tend, tend_physics, state, diag, mesh, configs, h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & - latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & - tend_rtheta_adv, rthdynten, & + config_mpas_cam_coef, & + config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & + config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & + rthdynten, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) - if (inactive_rthdynten) then - deallocate(rthdynten) - end if - end subroutine atm_compute_dyn_tend @@ -4158,12 +4465,15 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm h_divergence, kdiff, edgesOnCell_sign, edgesOnVertex_sign, rw_save, ru_save, & theta_m_save, exner, rr_save, scalars, tend_u_euler, tend_w_euler, tend_theta_euler, deriv_two, & cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnEdge, cellsOnCell, edgesOnVertex, nEdgesOnCell, nEdgesOnEdge, & - latCell, latEdge, angleEdge, u_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & + latCell, latEdge, angleEdge, u_init, v_init, advCellsForEdge, nAdvCellsForEdge, adv_coefs, adv_coefs_3rd, & rdzu, rdzw, fzm, fzp, qv_init, t_init, cf1, cf2, cf3, r_earth, ur_cell, vr_cell, defc_a, defc_b, & tend_w_pgf, tend_w_buoy, coef_3rd_order, c_s, config_mix_full, config_horiz_mixing, config_del4u_div_factor, & config_h_mom_eddy_visc2, config_v_mom_eddy_visc2, config_h_theta_eddy_visc2, config_v_theta_eddy_visc2, & config_h_theta_eddy_visc4, config_h_mom_eddy_visc4, config_visc4_2dsmag, config_len_disp, rk_step, dt, & - tend_rtheta_adv, rthdynten, & + config_mpas_cam_coef, & + config_rayleigh_damp_u, config_rayleigh_damp_u_timescale_days, & + config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels, & + rthdynten, & cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) @@ -4242,7 +4552,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND), dimension(nCells+1) :: latCell real (kind=RKIND), dimension(nEdges+1) :: latEdge real (kind=RKIND), dimension(nEdges+1) :: angleEdge - real (kind=RKIND), dimension(nVertLevels) :: u_init + real (kind=RKIND), dimension(nVertLevels) :: u_init, v_init integer, dimension(15,nEdges+1) :: advCellsForEdge integer, dimension(nEdges+1) :: nAdvCellsForEdge @@ -4282,7 +4592,12 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm integer, intent(in) :: rk_step real (kind=RKIND), intent(in) :: dt - real (kind=RKIND), dimension(nVertLevels,nCells+1) :: tend_rtheta_adv + real (kind=RKIND) :: config_mpas_cam_coef + + logical, intent(in) :: config_rayleigh_damp_u + real (kind=RKIND), intent(in) :: config_rayleigh_damp_u_timescale_days + integer, intent(in) :: config_number_rayleigh_damp_u_levels, config_number_cam_damping_levels + real (kind=RKIND), dimension(nVertLevels,nCells+1) :: rthdynten integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd @@ -4308,9 +4623,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm real (kind=RKIND) :: h_theta_eddy_visc4, v_theta_eddy_visc2 real (kind=RKIND) :: u_diffusion - real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp + real (kind=RKIND) :: kdiffu, z1, z2, z3, z4, zm, z0, zp, rayleigh_coef_inverse, visc2cam - + real (kind=RKIND), dimension( nVertLevels ) :: rayleigh_damp_coef real (kind=RKIND) :: flux3, flux4 real (kind=RKIND) :: q_im2, q_im1, q_i, q_ip1, ua, coef3 @@ -4322,7 +4637,6 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm flux4(q_im2, q_im1, q_i, q_ip1, ua) + & coef3*abs(ua)*((q_ip1 - q_im2)-3.*(q_i-q_im1))/12.0 - prandtl_inv = 1.0_RKIND / prandtl invDt = 1.0_RKIND / dt inv_r_earth = 1.0_RKIND / r_earth @@ -4367,6 +4681,22 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm h_theta_eddy_visc4 = config_h_theta_eddy_visc4 end if + + if (config_mpas_cam_coef > 0.0) then + + do iCell = cellStart,cellEnd + ! + ! 2nd-order filter for top absorbing layer similar to that in CAM-SE : WCS 10 May 2017, modified 7 April 2023 + ! From MPAS-CAM V4.0 code, with addition to config-specified coefficient (V4.0_coef = 0.2; SE_coef = 1.0) + ! + do k = nVertLevels-config_number_cam_damping_levels + 1, nVertLevels + visc2cam = 4.0*2.0833*config_len_disp*config_mpas_cam_coef + visc2cam = visc2cam*(1.0-real(nVertLevels-k)/real(config_number_cam_damping_levels)) + kdiff(k ,iCell) = max(kdiff(nVertLevels ,iCell),visc2cam) + end do + end do + + end if end if @@ -4558,6 +4888,9 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm end do end do + + + !$OMP BARRIER do iEdge=edgeSolveStart,edgeSolveEnd @@ -4626,11 +4959,8 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm cell2 = cellsOnEdge(2,iEdge) do k=1,nVertLevels -#ifdef ROTATED_GRID - u_mix(k) = u(k,iEdge) - u_init(k) * sin( angleEdge(iEdge) ) -#else - u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) -#endif + u_mix(k) = u(k,iEdge) - u_init(k) * cos( angleEdge(iEdge) ) & + - v_init(k) * sin( angleEdge(iEdge) ) end do do k=2,nVertLevels-1 @@ -4658,7 +4988,23 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !$OMP BARRIER -! add in mixing for u +! add in mixing and physics tendency for u + +! Rayleigh damping on u + if (config_rayleigh_damp_u) then + rayleigh_coef_inverse = 1.0 / ( real(config_number_rayleigh_damp_u_levels) & + * (config_rayleigh_damp_u_timescale_days*seconds_per_day) ) + do k=nVertLevels-config_number_rayleigh_damp_u_levels+1,nVertLevels + rayleigh_damp_coef(k) = real(k - (nVertLevels-config_number_rayleigh_damp_u_levels))*rayleigh_coef_inverse + end do + + do iEdge=edgeSolveStart,edgeSolveEnd +!DIR$ IVDEP + do k=nVertlevels-config_number_rayleigh_damp_u_levels+1,nVertLevels + tend_u(k,iEdge) = tend_u(k,iEdge) - rho_edge(k,iEdge)*u(k,iEdge)*rayleigh_damp_coef(k) + end do + end do + end if do iEdge=edgeSolveStart,edgeSolveEnd !DIR$ IVDEP @@ -4980,8 +5326,7 @@ subroutine atm_compute_dyn_tend_work(nCells, nEdges, nVertices, nVertLevels_dumm !DIR$ IVDEP do k=1,nVertLevels tend_theta(k,iCell) = tend_theta(k,iCell)*invAreaCell(iCell) -rdzw(k)*(wdtz(k+1)-wdtz(k)) - tend_rtheta_adv(k,iCell) = tend_theta(k,iCell) ! this is for the Tiedke scheme - rthdynten(k,iCell) = tend_theta(k,iCell)/rho_zz(k,iCell) ! this is for the Grell-Freitas scheme + rthdynten(k,iCell) = (tend_theta(k,iCell)-tend_rho(k,iCell)*theta_m(k,iCell))/rho_zz(k,iCell) tend_theta(k,iCell) = tend_theta(k,iCell) + rho_zz(k,iCell)*rt_diabatic_tend(k,iCell) end do end do @@ -5581,51 +5926,653 @@ subroutine atm_init_coupled_diagnostics(state, time_lev, diag, mesh, configs, & - edgesOnCell_sign(i,iCell) * (zb_cell(k,i,iCell) + sign(1.0_RKIND,flux) * zb3_cell(k,i,iCell))*flux & * (fzp(k) * zz(k-1,iCell) + fzm(k) * zz(k,iCell)) end do - end do - end do + end do + end do + + do iCell=cellStart,cellEnd + do k=1,nVertLevels + rho_p(k,iCell) = rho_zz(k,iCell) - rho_base(k,iCell) + end do + end do + + do iCell=cellStart,cellEnd + do k=1,nVertLevels + rtheta_base(k,iCell) = theta_base(k,iCell) * rho_base(k,iCell) + end do + end do + + do iCell=cellStart,cellEnd + do k=1,nVertLevels + rtheta_p(k,iCell) = theta_m(k,iCell) * rho_p(k,iCell) & + + rho_base(k,iCell) * (theta_m(k,iCell) - theta_base(k,iCell)) + end do + end do + + do iCell=cellStart,cellEnd + do k=1,nVertLevels + exner(k,iCell) = (zz(k,iCell) * (rgas/p0) * (rtheta_p(k,iCell) + rtheta_base(k,iCell)))**rcv + exner_base(k,iCell) = (zz(k,iCell) * (rgas/p0) * (rtheta_base(k,iCell)))**rcv ! WCS addition 20180403 + end do + end do + + do iCell=cellStart,cellEnd + do k=1,nVertLevels + pressure_p(k,iCell) = zz(k,iCell) * rgas & + * ( exner(k,iCell) * rtheta_p(k,iCell) & + + rtheta_base(k,iCell) * (exner(k,iCell) - exner_base(k,iCell)) & + ) + pressure_base(k,iCell) = zz(k,iCell) * rgas * exner_base(k,iCell) * rtheta_base(k,iCell) ! WCS addition 20180403 + end do + end do + + end subroutine atm_init_coupled_diagnostics + + + subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynamics_split, & + cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS 18 November 2014 + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + integer, intent(in) :: dynamics_substep, dynamics_split + integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND) :: inv_dynamics_split + + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: ru_save + real (kind=RKIND), dimension(:,:), pointer :: rw + real (kind=RKIND), dimension(:,:), pointer :: rw_save + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p + real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save + real (kind=RKIND), dimension(:,:), pointer :: rho_p + real (kind=RKIND), dimension(:,:), pointer :: rho_p_save + + real (kind=RKIND), dimension(:,:), pointer :: u_1, u_2 + real (kind=RKIND), dimension(:,:), pointer :: w_1, w_2 + real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 + real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2, rho_zz_old_split + real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg, ruAvg_split, wwAvg_split + + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'ru_save', ru_save) + call mpas_pool_get_array(diag, 'rw', rw) + call mpas_pool_get_array(diag, 'rw_save', rw_save) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) + call mpas_pool_get_array(diag, 'rho_p', rho_p) + call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) + call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) + call mpas_pool_get_array(diag, 'ruAvg', ruAvg) + call mpas_pool_get_array(diag, 'ruAvg_split', ruAvg_split) + call mpas_pool_get_array(diag, 'wwAvg', wwAvg) + call mpas_pool_get_array(diag, 'wwAvg_split', wwAvg_split) + + call mpas_pool_get_array(state, 'u', u_1, 1) + call mpas_pool_get_array(state, 'u', u_2, 2) + call mpas_pool_get_array(state, 'w', w_1, 1) + call mpas_pool_get_array(state, 'w', w_2, 2) + call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) + call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) + call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) + + inv_dynamics_split = 1.0_RKIND / real(dynamics_split) + + if (dynamics_substep < dynamics_split) then + + ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) + rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) + rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) + rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) + + u_1(:,edgeStart:edgeEnd) = u_2(:,edgeStart:edgeEnd) + w_1(:,cellStart:cellEnd) = w_2(:,cellStart:cellEnd) + theta_m_1(:,cellStart:cellEnd) = theta_m_2(:,cellStart:cellEnd) + rho_zz_1(:,cellStart:cellEnd) = rho_zz_2(:,cellStart:cellEnd) + + end if + + if (dynamics_substep == 1) then + ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd) + wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd) + else + ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd)+ruAvg_split(:,edgeStart:edgeEnd) + wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd)+wwAvg_split(:,cellStart:cellEnd) + end if + + if (dynamics_substep == dynamics_split) then + ruAvg(:,edgeStart:edgeEnd) = ruAvg_split(:,edgeStart:edgeEnd) * inv_dynamics_split + wwAvg(:,cellStart:cellEnd) = wwAvg_split(:,cellStart:cellEnd) * inv_dynamics_split + rho_zz_1(:,cellStart:cellEnd) = rho_zz_old_split(:,cellStart:cellEnd) + end if + + end subroutine atm_rk_dynamics_substep_finish + + +!------------------------------------------------------------------------- +! +! these next 2 routines set an approximate zero gradient boundary condition for w for regional_MPAS +! + subroutine atm_zero_gradient_w_bdy( state, mesh, cellSolveStart, cellSolveEnd ) + + ! reconstitute state variables from acoustic-step perturbation variables + ! after the acoustic steps. The perturbation variables were originally set in + ! subroutine atm_set_smlstep_pert_variables prior to their acoustic-steps update. + ! we are also computing a few other state-derived variables here. + + implicit none + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: cellSolveStart, cellSolveEnd + + real (kind=RKIND), dimension(:,:), pointer :: w + + integer, dimension(:), pointer :: bdyMaskCell, nearestRelaxationCell + integer, pointer :: nCells + + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'nearestRelaxationCell', nearestRelaxationCell) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + + call atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, nCells, cellSolveStart, cellSolveEnd ) + + end subroutine atm_zero_gradient_w_bdy + +!------------------------------------------------------------------------- + + subroutine atm_zero_gradient_w_bdy_work( w, bdyMaskCell, nearestRelaxationCell, nCells, cellSolveStart, cellSolveEnd ) + + use mpas_atm_dimensions + + implicit none + + ! + ! Dummy arguments + ! + integer, intent(in) :: cellSolveStart, cellSolveEnd, nCells + integer, dimension(nCells+1), intent(in) :: bdyMaskCell, nearestRelaxationCell + real (kind=RKIND), dimension(nVertLevels+1,nCells+1), intent(inout) :: w + + ! local variables + + integer :: iCell, k + + do iCell=cellSolveStart,cellSolveEnd + if (bdyMaskCell(iCell) > nRelaxZone) then +!DIR$ IVDEP + do k = 2, nVertLevels + w(k,iCell) = w(k,nearestRelaxationCell(iCell)) + end do + end if + end do + + end subroutine atm_zero_gradient_w_bdy_work + +!------------------------------------------------------------------------- + + subroutine atm_bdy_adjust_dynamics_speczone_tend( tend, mesh, config, nVertLevels, & + ru_driving_tend, rt_driving_tend, rho_driving_tend, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd ) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS Fall 2016 + + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_tend, rt_driving_tend, rho_driving_tend + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, rt_diabatic_tend + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge + + integer :: iCell, iEdge, k + + call mpas_pool_get_array(tend, 'u', tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + call mpas_pool_get_array(tend, 'rt_diabatic_tend', rt_diabatic_tend) + + do iCell = cellSolveStart, cellSolveEnd + if(bdyMaskCell(iCell) > nRelaxZone) then + do k=1, nVertLevels + tend_rho(k,iCell) = rho_driving_tend(k,iCell) + tend_rt(k,iCell) = rt_driving_tend(k,iCell) + tend_rw(k,iCell) = 0. + rt_diabatic_tend(k,iCell) = 0. + end do + end if + end do + + do iEdge = edgeSolveStart, edgeSolveEnd + if(bdyMaskEdge(iEdge) > nRelaxZone) then + do k=1, nVertLevels + tend_ru(k,iEdge) = ru_driving_tend(k,iEdge) + end do + end if + end do + + end subroutine atm_bdy_adjust_dynamics_speczone_tend + +!------------------------------------------------------------------------- + + subroutine atm_bdy_adjust_dynamics_relaxzone_tend( config, tend, state, diag, mesh, nVertLevels, dt, & + ru_driving_values, rt_driving_values, rho_driving_values, & + cellStart, cellEnd, edgeStart, edgeEnd, & + cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd ) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS Fall 2016 + + type (mpas_pool_type), intent(in) :: config + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(inout) :: tend + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd, edgeStart, edgeEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd, edgeSolveStart, edgeSolveEnd + + real (kind=RKIND), intent(in) :: dt + + real (kind=RKIND), dimension(:,:), intent(in) :: ru_driving_values, rt_driving_values, rho_driving_values + + real (kind=RKIND), dimension(:,:), pointer :: tend_ru, tend_rt, tend_rho, tend_rw, ru, theta_m, rho_zz + real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, invDcEdge, invDvEdge, invAreaCell, invAreaTriangle + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign, edgesOnVertex_sign + integer, dimension(:), pointer :: bdyMaskCell, bdyMaskEdge, nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, verticesOnEdge, edgesOnCell, edgesOnVertex + integer, pointer :: vertexDegree + + + real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, r_dc, r_dv, invArea + real (kind=RKIND), pointer :: divdamp_coef + real (kind=RKIND), dimension(nVertLevels) :: divergence1, divergence2, vorticity1, vorticity2 + integer :: iCell, iEdge, i, k, cell1, cell2, iEdge_vort, iEdge_div + integer :: vertex1, vertex2, iVertex + + real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge + + call mpas_pool_get_array(tend, 'u', tend_ru) + call mpas_pool_get_array(tend, 'rho_zz', tend_rho) + call mpas_pool_get_array(tend, 'theta_m', tend_rt) + call mpas_pool_get_array(tend, 'w', tend_rw) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'bdyMaskEdge', bdyMaskEdge) + + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) + call mpas_pool_get_array(mesh, 'meshScalingRegionalEdge', meshScalingRegionalEdge) + + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(state, 'rho_zz', rho_zz, 2) + + call mpas_pool_get_dimension(mesh, 'vertexDegree', vertexDegree) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge) + call mpas_pool_get_array(mesh, 'invDvEdge', invDvEdge) + call mpas_pool_get_array(mesh, 'invAreaCell', invAreaCell) + call mpas_pool_get_array(mesh, 'invAreaTriangle', invAreaTriangle) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + call mpas_pool_get_array(mesh, 'edgesOnVertex_sign', edgesOnVertex_sign) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnVertex', edgesOnVertex) + call mpas_pool_get_array(mesh, 'nEdgesOnCell',nEdgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnEdge', verticesOnEdge) + + call mpas_pool_get_config(config, 'config_relax_zone_divdamp_coef', divdamp_coef) + + ! First, Rayleigh damping terms for ru, rtheta_m and rho_zz + + do iCell = cellSolveStart, cellSolveEnd + if( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then + rayleigh_damping_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalCell(iCell)) + do k=1, nVertLevels + tend_rho(k,iCell) = tend_rho(k,iCell) - rayleigh_damping_coef * (rho_zz(k,iCell) - rho_driving_values(k,iCell)) + tend_rt(k,iCell) = tend_rt(k,iCell) - rayleigh_damping_coef * (rho_zz(k,iCell)*theta_m(k,iCell) - rt_driving_values(k,iCell)) + end do + end if + end do + + do iEdge = edgeStart, edgeEnd + if( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then + rayleigh_damping_coef = (real(bdyMaskEdge(iEdge)) - 1.)/real(nRelaxZone)/(50.*dt*meshScalingRegionalEdge(iEdge)) + do k=1, nVertLevels + tend_ru(k,iEdge) = tend_ru(k,iEdge) - rayleigh_damping_coef * (ru(k,iEdge) - ru_driving_values(k,iEdge)) + end do + end if + end do + + ! Second, the horizontal filter for rtheta_m and rho_zz + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + + if ( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then ! relaxation zone + + laplacian_filter_coef = (real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt*meshScalingRegionalCell(iCell)) + ! + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + ! edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + ! this is a dimensionless laplacian, so we leave out the r_areaCell + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + tend_rt(k,iCell) = tend_rt(k,iCell) + edge_sign*( (rho_zz(k,cell2)*theta_m(k,cell2)-rt_driving_values(k,cell2)) & + - (rho_zz(k,cell1)*theta_m(k,cell1)-rt_driving_values(k,cell1)) ) + tend_rho(k,iCell) = tend_rho(k,iCell) + edge_sign*( (rho_zz(k,cell2)-rho_driving_values(k,cell2)) & + - (rho_zz(k,cell1)-rho_driving_values(k,cell1)) ) + end do + end do + + end if + + end do + + ! Third (and last), the horizontal filter for ru + + do iEdge = edgeStart, edgeEnd + + if ( (bdyMaskEdge(iEdge) > 1) .and. (bdyMaskEdge(iEdge) <= nRelaxZone) ) then ! relaxation zone + + laplacian_filter_coef = dcEdge(iEdge)**2 * (real(bdyMaskEdge(iEdge)) - 1.)/ & + real(nRelaxZone)/(10.*dt*meshScalingRegionalEdge(iEdge)) + + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + vertex1 = verticesOnEdge(1,iEdge) + vertex2 = verticesOnEdge(2,iEdge) + r_dc = invDcEdge(iEdge) + r_dv = min(invDvEdge(iEdge), 4*invDcEdge(iEdge)) + + iCell = cell1 + invArea = invAreaCell(iCell) + divergence1(1:nVertLevels) = 0. + do i=1,nEdgesOnCell(iCell) + iEdge_div = edgesOnCell(i,iCell) + edge_sign = invArea * dvEdge(iEdge_div) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + divergence1(k) = divergence1(k) + edge_sign * (ru(k,iEdge_div) - ru_driving_values(k,iEdge_div)) + end do + end do + + iCell = cell2 + invArea = invAreaCell(iCell) + divergence2(1:nVertLevels) = 0. + do i=1,nEdgesOnCell(iCell) + iEdge_div = edgesOnCell(i,iCell) + edge_sign = invArea * dvEdge(iEdge_div) * edgesOnCell_sign(i,iCell) + do k=1,nVertLevels + divergence2(k) = divergence2(k) + edge_sign * (ru(k,iEdge_div) - ru_driving_values(k,iEdge_div)) + end do + end do + + iVertex = vertex1 + vorticity1(1:nVertLevels) = 0. + do i=1,vertexDegree + iEdge_vort = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + vorticity1(k) = vorticity1(k) + edge_sign * (ru(k,iEdge_vort) - ru_driving_values(k,iEdge_vort)) + end do + end do + + iVertex = vertex2 + vorticity2(1:nVertLevels) = 0. + do i=1,vertexDegree + iEdge_vort = edgesOnVertex(i,iVertex) + edge_sign = invAreaTriangle(iVertex) * dcEdge(iEdge_vort) * edgesOnVertex_sign(i,iVertex) + do k=1,nVertLevels + vorticity2(k) = vorticity2(k) + edge_sign * (ru(k,iEdge_vort) - ru_driving_values(k,iEdge_vort)) + end do + end do + + ! Compute diffusion, computed as \nabla divergence - k \times \nabla vorticity + ! + do k=1,nVertLevels + tend_ru(k,iEdge) = tend_ru(k,iEdge) + laplacian_filter_coef & + * (divdamp_coef * (divergence2(k) - divergence1(k)) * r_dc & + -(vorticity2(k) - vorticity1(k)) * r_dv) + end do + + end if ! end test for relaxation-zone edge + + end do ! end of loop over edges + + end subroutine atm_bdy_adjust_dynamics_relaxzone_tend + + + subroutine atm_bdy_reset_speczone_values( state, diag, mesh, nVertLevels, & + rt_driving_values, rho_driving_values, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) + + implicit none + + ! this routine resets theta_m and rtheta_m after the microphysics, i.e. at the very end of the timestep + ! + ! WCS 24 February 2017 + + type (mpas_pool_type), intent(in) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + + real (kind=RKIND), dimension(:,:), intent(in) :: rt_driving_values, rho_driving_values + + real (kind=RKIND), dimension(:,:), pointer :: theta_m, rtheta_p, rtheta_base + integer, dimension(:), pointer :: bdyMaskCell + + integer :: iCell, k + + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(state, 'theta_m', theta_m, 2) + call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) + call mpas_pool_get_array(diag, 'rtheta_base', rtheta_base) + + do iCell = cellSolveStart, cellSolveEnd + if( bdyMaskCell(iCell) > nRelaxZone) then + do k=1, nVertLevels + theta_m(k,iCell) = rt_driving_values(k,iCell)/rho_driving_values(k,iCell) + rtheta_p(k,iCell) = rt_driving_values(k,iCell) - rtheta_base(k,iCell) + end do + end if + end do + + end subroutine atm_bdy_reset_speczone_values + +!------------------------------------------------------------------------- + subroutine atm_bdy_adjust_scalars( state, diag, mesh, config, scalars_driving, nVertLevels, dt, dt_rk, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) + + implicit none + + ! this routine resets the dry dynamics variables at the end of an rk3 substep for the case + ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is + ! using a different, usually smaller, timestep. + ! + ! WCS 24 February 2017 + + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(in) :: diag + type (mpas_pool_type), intent(in) :: mesh + type (mpas_pool_type), intent(in) :: config + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + + real (kind=RKIND), intent(in) :: dt, dt_rk + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new + real (kind=RKIND), dimension(:,:), pointer :: edgesOnCell_sign + + real (kind=RKIND), dimension(:), pointer :: invDcEdge, dvEdge, meshScalingRegionalCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: edgesOnCell, cellsOnEdge + integer, pointer :: nCells, maxEdges, num_scalars + integer, dimension(:), pointer :: bdyMaskCell + + call mpas_pool_get_array(state, 'scalars', scalars_new, 2) + + call mpas_pool_get_array(mesh, 'invDcEdge', invDcEdge ) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge ) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) + call mpas_pool_get_array(mesh, 'edgesOnCell_sign', edgesOnCell_sign) + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'maxEdges', maxEdges) + + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + + call atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & + nVertLevels, nCells, num_scalars, & + nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + meshScalingRegionalCell, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) + + end subroutine atm_bdy_adjust_scalars + +!------------------------------------------------------------------------- + + subroutine atm_bdy_adjust_scalars_work( scalars_new, scalars_driving, dt, dt_rk, & + nVertLevels, nCells, num_scalars, & + nEdgesOnCell, edgesOnCell, EdgesOnCell_sign, cellsOnEdge, dvEdge, invDcEdge, bdyMaskCell, & + meshScalingRegionalCell, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) + + implicit none + + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new + real (kind=RKIND), dimension(:,:), intent(in) :: edgesOnCell_sign + integer, intent(in) :: nVertLevels, nCells, num_scalars + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, dimension(:), intent(in) :: nEdgesOnCell, bdyMaskCell + integer, dimension(:,:), intent(in) :: edgesOnCell, cellsOnEdge + real (kind=RKIND), dimension(:), intent(in) :: dvEdge, invDcEdge, meshScalingRegionalCell + real (kind=RKIND), intent(in) :: dt, dt_rk + + ! local variables + + real (kind=RKIND), dimension(1:num_scalars,1:nVertLevels, cellSolveStart:cellSolveEnd) :: scalars_tmp + real (kind=RKIND) :: edge_sign, laplacian_filter_coef, rayleigh_damping_coef, filter_flux + integer :: iCell, iEdge, iScalar, i, k, cell1, cell2 + + !--- + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + + if ( (bdyMaskCell(iCell) > 1) .and. (bdyMaskCell(iCell) <= nRelaxZone) ) then ! relaxation zone + + laplacian_filter_coef = dt_rk*(real(bdyMaskCell(iCell)) - 1.)/real(nRelaxZone)/(10.*dt*meshScalingRegionalCell(iCell)) + rayleigh_damping_coef = laplacian_filter_coef/5.0 + scalars_tmp(1:num_scalars,1:nVertLevels,iCell) = scalars_new(1:num_scalars,1:nVertLevels,iCell) + + ! first, we compute the 2nd-order laplacian filter + ! + do i=1,nEdgesOnCell(iCell) + iEdge = edgesOnCell(i,iCell) + ! edge_sign = r_areaCell*edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + ! this is a dimensionless laplacian, so we leave out the r_areaCell + edge_sign = edgesOnCell_sign(i,iCell) * dvEdge(iEdge) * invDcEdge(iEdge) * laplacian_filter_coef + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + filter_flux = edge_sign*( (scalars_new(iScalar,k,cell2)-scalars_driving(iScalar,k,cell2)) & + - (scalars_new(iScalar,k,cell1)-scalars_driving(iScalar,k,cell1)) ) + scalars_tmp(iScalar,k,iCell) = scalars_tmp(iScalar,k,iCell) + filter_flux + end do + end do + end do - do iCell=cellStart,cellEnd - do k=1,nVertLevels - rho_p(k,iCell) = rho_zz(k,iCell) - rho_base(k,iCell) - end do - end do + ! second, we compute the Rayleigh damping component + ! +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_tmp(iScalar,k,iCell) =scalars_tmp(iScalar,k,iCell) - rayleigh_damping_coef * (scalars_new(iScalar,k,iCell)-scalars_driving(iScalar,k,iCell)) + end do + end do - do iCell=cellStart,cellEnd - do k=1,nVertLevels - rtheta_base(k,iCell) = theta_base(k,iCell) * rho_base(k,iCell) - end do - end do + else if ( bdyMaskCell(iCell) > nRelaxZone) then ! specified zone + + ! update the specified-zone values + ! +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_tmp(iScalar,k,iCell) = scalars_driving(iScalar,k,iCell) + end do + end do - do iCell=cellStart,cellEnd - do k=1,nVertLevels - rtheta_p(k,iCell) = theta_m(k,iCell) * rho_p(k,iCell) & - + rho_base(k,iCell) * (theta_m(k,iCell) - theta_base(k,iCell)) - end do - end do + end if - do iCell=cellStart,cellEnd - do k=1,nVertLevels - exner(k,iCell) = (zz(k,iCell) * (rgas/p0) * (rtheta_p(k,iCell) + rtheta_base(k,iCell)))**rcv - exner_base(k,iCell) = (zz(k,iCell) * (rgas/p0) * (rtheta_base(k,iCell)))**rcv ! WCS addition 20180403 - end do - end do + end do ! updates now in temp storage + +!$OMP BARRIER - do iCell=cellStart,cellEnd - do k=1,nVertLevels - pressure_p(k,iCell) = zz(k,iCell) * rgas & - * ( exner(k,iCell) * rtheta_p(k,iCell) & - + rtheta_base(k,iCell) * (exner(k,iCell) - exner_base(k,iCell)) & - ) - pressure_base(k,iCell) = zz(k,iCell) * rgas * exner_base(k,iCell) * rtheta_base(k,iCell) ! WCS addition 20180403 - end do + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + if (bdyMaskCell(iCell) > 1) then ! update values +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_new(iScalar,k,iCell) = scalars_tmp(iScalar,k,iCell) + end do + end do + end if end do - end subroutine atm_init_coupled_diagnostics + end subroutine atm_bdy_adjust_scalars_work +!------------------------------------------------------------------------- - subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynamics_split, & - cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd, & - cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd) + subroutine atm_bdy_set_scalars( state, mesh, scalars_driving, nVertLevels, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) implicit none @@ -5633,86 +6580,80 @@ subroutine atm_rk_dynamics_substep_finish( state, diag, dynamics_substep, dynami ! where the dry dynamics is split from the scalar transport (i.e. where the dry dynamics is ! using a different, usually smaller, timestep. ! - ! WCS 18 November 2014 + ! WCS 24 February 2017 type (mpas_pool_type), intent(inout) :: state - type (mpas_pool_type), intent(inout) :: diag - integer, intent(in) :: dynamics_substep, dynamics_split - integer, intent(in) :: cellStart, cellEnd, vertexStart, vertexEnd, edgeStart, edgeEnd - integer, intent(in) :: cellSolveStart, cellSolveEnd, vertexSolveStart, vertexSolveEnd, edgeSolveStart, edgeSolveEnd + type (mpas_pool_type), intent(in) :: mesh + integer, intent(in) :: nVertLevels + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd - real (kind=RKIND) :: inv_dynamics_split - - real (kind=RKIND), dimension(:,:), pointer :: ru - real (kind=RKIND), dimension(:,:), pointer :: ru_save - real (kind=RKIND), dimension(:,:), pointer :: rw - real (kind=RKIND), dimension(:,:), pointer :: rw_save - real (kind=RKIND), dimension(:,:), pointer :: rtheta_p - real (kind=RKIND), dimension(:,:), pointer :: rtheta_p_save - real (kind=RKIND), dimension(:,:), pointer :: rho_p - real (kind=RKIND), dimension(:,:), pointer :: rho_p_save + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving - real (kind=RKIND), dimension(:,:), pointer :: u_1, u_2 - real (kind=RKIND), dimension(:,:), pointer :: w_1, w_2 - real (kind=RKIND), dimension(:,:), pointer :: theta_m_1, theta_m_2 - real (kind=RKIND), dimension(:,:), pointer :: rho_zz_1, rho_zz_2, rho_zz_old_split - real (kind=RKIND), dimension(:,:), pointer :: ruAvg, wwAvg, ruAvg_split, wwAvg_split + real (kind=RKIND), dimension(:,:,:), pointer :: scalars_new + integer, pointer :: nCells, num_scalars + integer, dimension(:), pointer :: bdyMaskCell - call mpas_pool_get_array(diag, 'ru', ru) - call mpas_pool_get_array(diag, 'ru_save', ru_save) - call mpas_pool_get_array(diag, 'rw', rw) - call mpas_pool_get_array(diag, 'rw_save', rw_save) - call mpas_pool_get_array(diag, 'rtheta_p', rtheta_p) - call mpas_pool_get_array(diag, 'rtheta_p_save', rtheta_p_save) - call mpas_pool_get_array(diag, 'rho_p', rho_p) - call mpas_pool_get_array(diag, 'rho_p_save', rho_p_save) - call mpas_pool_get_array(diag, 'rho_zz_old_split', rho_zz_old_split) - call mpas_pool_get_array(diag, 'ruAvg', ruAvg) - call mpas_pool_get_array(diag, 'ruAvg_split', ruAvg_split) - call mpas_pool_get_array(diag, 'wwAvg', wwAvg) - call mpas_pool_get_array(diag, 'wwAvg_split', wwAvg_split) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) - call mpas_pool_get_array(state, 'u', u_1, 1) - call mpas_pool_get_array(state, 'u', u_2, 2) - call mpas_pool_get_array(state, 'w', w_1, 1) - call mpas_pool_get_array(state, 'w', w_2, 2) - call mpas_pool_get_array(state, 'theta_m', theta_m_1, 1) - call mpas_pool_get_array(state, 'theta_m', theta_m_2, 2) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_1, 1) - call mpas_pool_get_array(state, 'rho_zz', rho_zz_2, 2) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) - inv_dynamics_split = 1.0_RKIND / real(dynamics_split) - - if (dynamics_substep < dynamics_split) then + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - ru_save(:,edgeStart:edgeEnd) = ru(:,edgeStart:edgeEnd) - rw_save(:,cellStart:cellEnd) = rw(:,cellStart:cellEnd) - rtheta_p_save(:,cellStart:cellEnd) = rtheta_p(:,cellStart:cellEnd) - rho_p_save(:,cellStart:cellEnd) = rho_p(:,cellStart:cellEnd) + call mpas_pool_get_array(state, 'scalars', scalars_new, 2) - u_1(:,edgeStart:edgeEnd) = u_2(:,edgeStart:edgeEnd) - w_1(:,cellStart:cellEnd) = w_2(:,cellStart:cellEnd) - theta_m_1(:,cellStart:cellEnd) = theta_m_2(:,cellStart:cellEnd) - rho_zz_1(:,cellStart:cellEnd) = rho_zz_2(:,cellStart:cellEnd) + call atm_bdy_set_scalars_work( scalars_driving, scalars_new, & + nVertLevels, nCells, num_scalars, & + bdyMaskCell, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) - end if + end subroutine atm_bdy_set_scalars - if (dynamics_substep == 1) then - ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd) - wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd) - else - ruAvg_split(:,edgeStart:edgeEnd) = ruAvg(:,edgeStart:edgeEnd)+ruAvg_split(:,edgeStart:edgeEnd) - wwAvg_split(:,cellStart:cellEnd) = wwAvg(:,cellStart:cellEnd)+wwAvg_split(:,cellStart:cellEnd) - end if +!------------------------------------------------------------------------- - if (dynamics_substep == dynamics_split) then - ruAvg(:,edgeStart:edgeEnd) = ruAvg_split(:,edgeStart:edgeEnd) * inv_dynamics_split - wwAvg(:,cellStart:cellEnd) = wwAvg_split(:,cellStart:cellEnd) * inv_dynamics_split - rho_zz_1(:,cellStart:cellEnd) = rho_zz_old_split(:,cellStart:cellEnd) - end if + subroutine atm_bdy_set_scalars_work( scalars_driving, scalars_new, & + nVertLevels, nCells, num_scalars, & + bdyMaskCell, & + cellStart, cellEnd, & + cellSolveStart, cellSolveEnd ) - end subroutine atm_rk_dynamics_substep_finish + implicit none + + real (kind=RKIND), dimension(:,:,:), intent(in) :: scalars_driving + real (kind=RKIND), dimension(:,:,:), intent(inout) :: scalars_new + integer, intent(in) :: nVertLevels, nCells, num_scalars + integer, intent(in) :: cellStart, cellEnd + integer, intent(in) :: cellSolveStart, cellSolveEnd + integer, dimension(:), intent(in) :: bdyMaskCell + + ! local variables + + real (kind=RKIND) :: laplacian_filter_coef, rayleigh_damping_coef, filter_flux + integer :: iCell, iScalar, i, k, cell1, cell2 + + !--- + + do iCell = cellSolveStart, cellSolveEnd ! threaded over cells + + if ( bdyMaskCell(iCell) > nRelaxZone) then ! specified zone + + ! update the specified-zone values + ! +!DIR$ IVDEP + do k=1,nVertLevels + do iScalar = 1, num_scalars + scalars_new(iScalar,k,iCell) = scalars_driving(iScalar,k,iCell) + end do + end do + + end if + end do ! updates now in temp storage + + end subroutine atm_bdy_set_scalars_work + +!------------------------------------------------------------------------- subroutine summarize_timestep(domain) @@ -5728,8 +6669,6 @@ subroutine summarize_timestep(domain) logical, pointer :: config_print_detailed_minmax_vel logical, pointer :: config_print_global_minmax_sca - type (block_type), pointer :: block - integer :: iCell, k, iEdge, iScalar integer, pointer :: num_scalars, nCellsSolve, nEdgesSolve, nVertLevels @@ -5756,273 +6695,262 @@ subroutine summarize_timestep(domain) real (kind=RKIND), dimension(:,:), pointer :: u, v, uReconstructZonal, uReconstructMeridional, uReconstructX, uReconstructY, uReconstructZ real (kind=RKIND), dimension(:,:,:), pointer :: scalars, scalars_1, scalars_2 - call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_vel', config_print_global_minmax_vel) - call mpas_pool_get_config(domain % blocklist % configs, 'config_print_detailed_minmax_vel', config_print_detailed_minmax_vel) - call mpas_pool_get_config(domain % blocklist % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) + call mpas_pool_get_config(block % configs, 'config_print_global_minmax_vel', config_print_global_minmax_vel) + call mpas_pool_get_config(block % configs, 'config_print_detailed_minmax_vel', config_print_detailed_minmax_vel) + call mpas_pool_get_config(block % configs, 'config_print_global_minmax_sca', config_print_global_minmax_sca) if (config_print_detailed_minmax_vel) then call mpas_log_write('') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - call mpas_pool_get_subpool(block % structs, 'diag', diag) - call mpas_pool_get_subpool(block % structs, 'mesh', mesh) - - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_array(diag, 'v', v) - call mpas_pool_get_array(mesh, 'indexToCellID', indexToCellID) - call mpas_pool_get_array(mesh, 'latCell', latCell) - call mpas_pool_get_array(mesh, 'lonCell', lonCell) - call mpas_pool_get_array(mesh, 'latEdge', latEdge) - call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) - call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - - scalar_min = 1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - if (w(k,iCell) < scalar_min) then - scalar_min = w(k,iCell) - indexMax = iCell - kMax = k - latMax = latCell(iCell) - lonMax = lonCell(iCell) - end if - end do - end do - localVals(1) = scalar_min - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) - global_scalar_min = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_subpool(block % structs, 'diag', diag) + call mpas_pool_get_subpool(block % structs, 'mesh', mesh) + + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_array(diag, 'v', v) + call mpas_pool_get_array(mesh, 'indexToCellID', indexToCellID) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + + scalar_min = 1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + if (w(k,iCell) < scalar_min) then + scalar_min = w(k,iCell) + indexMax = iCell + kMax = k + latMax = latCell(iCell) + lonMax = lonCell(iCell) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) - - scalar_max = -1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - if (w(k,iCell) > scalar_max) then - scalar_max = w(k,iCell) - indexMax = iCell - kMax = k - latMax = latCell(iCell) - lonMax = lonCell(iCell) - end if - end do - end do - localVals(1) = scalar_max - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) - global_scalar_max = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_min + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) + global_scalar_min = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global min w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + + scalar_max = -1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + if (w(k,iCell) > scalar_max) then + scalar_max = w(k,iCell) + indexMax = iCell + kMax = k + latMax = latCell(iCell) + lonMax = lonCell(iCell) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - - scalar_min = 1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - if (u(k,iEdge) < scalar_min) then - scalar_min = u(k,iEdge) - indexMax = iEdge - kMax = k - latMax = latEdge(iEdge) - lonMax = lonEdge(iEdge) - end if - end do - end do - localVals(1) = scalar_min - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) - global_scalar_min = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_max + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) + global_scalar_max = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max w: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + + scalar_min = 1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + if (u(k,iEdge) < scalar_min) then + scalar_min = u(k,iEdge) + indexMax = iEdge + kMax = k + latMax = latEdge(iEdge) + lonMax = lonEdge(iEdge) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) - - scalar_max = -1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - if (u(k,iEdge) > scalar_max) then - scalar_max = u(k,iEdge) - indexMax = iEdge - kMax = k - latMax = latEdge(iEdge) - lonMax = lonEdge(iEdge) - end if - end do - end do - localVals(1) = scalar_max - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) - global_scalar_max = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_min + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_minattributes_real(domain % dminfo, scalar_min, localVals, globalVals) + global_scalar_min = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global min u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_min, latMax_global, lonMax_global/)) + + scalar_max = -1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + if (u(k,iEdge) > scalar_max) then + scalar_max = u(k,iEdge) + indexMax = iEdge + kMax = k + latMax = latEdge(iEdge) + lonMax = lonEdge(iEdge) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - - scalar_max = -1.0e20 - indexMax = -1 - kMax = -1 - latMax = 0.0 - lonMax = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - spd = sqrt(u(k,iEdge)*u(k,iEdge) + v(k,iEdge)*v(k,iEdge)) - if (spd > scalar_max) then - scalar_max = spd - indexMax = iEdge - kMax = k - latMax = latEdge(iEdge) - lonMax = lonEdge(iEdge) - end if - end do - end do - localVals(1) = scalar_max - localVals(2) = real(indexMax,kind=RKIND) - localVals(3) = real(kMax,kind=RKIND) - localVals(4) = latMax - localVals(5) = lonMax - call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) - global_scalar_max = globalVals(1) - indexMax_global = int(globalVals(2)) - kMax_global = int(globalVals(3)) - latMax_global = globalVals(4) - lonMax_global = globalVals(5) - latMax_global = latMax_global * 180.0_RKIND / pi_const - lonMax_global = lonMax_global * 180.0_RKIND / pi_const - if (lonMax_global > 180.0) then - lonMax_global = lonMax_global - 360.0 + end do + end do + localVals(1) = scalar_max + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) + global_scalar_max = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max u: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) + + scalar_max = -1.0e20 + indexMax = -1 + kMax = -1 + latMax = 0.0 + lonMax = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + spd = sqrt(u(k,iEdge)*u(k,iEdge) + v(k,iEdge)*v(k,iEdge)) + if (spd > scalar_max) then + scalar_max = spd + indexMax = iEdge + kMax = k + latMax = latEdge(iEdge) + lonMax = lonEdge(iEdge) end if - ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' - call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & - realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - - ! - ! Check for NaNs - ! - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - if (ieee_is_nan(w(k,iCell))) then - call mpas_log_write('NaN detected in ''w'' field.', messageType=MPAS_LOG_CRIT) - end if - end do - end do + end do + end do + localVals(1) = scalar_max + localVals(2) = real(indexMax,kind=RKIND) + localVals(3) = real(kMax,kind=RKIND) + localVals(4) = latMax + localVals(5) = lonMax + call mpas_dmpar_maxattributes_real(domain % dminfo, scalar_max, localVals, globalVals) + global_scalar_max = globalVals(1) + indexMax_global = int(globalVals(2)) + kMax_global = int(globalVals(3)) + latMax_global = globalVals(4) + lonMax_global = globalVals(5) + latMax_global = latMax_global * 180.0_RKIND / pi_const + lonMax_global = lonMax_global * 180.0_RKIND / pi_const + if (lonMax_global > 180.0) then + lonMax_global = lonMax_global - 360.0 + end if + ! format statement should be '(a,f9.4,a,i4,a,f7.3,a,f8.3,a)' + call mpas_log_write(' global max wsp: $r k=$i, $r lat, $r lon', intArgs=(/kMax_global/), & + realArgs=(/global_scalar_max, latMax_global, lonMax_global/)) - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - if (ieee_is_nan(u(k,iEdge))) then - call mpas_log_write('NaN detected in ''u'' field.', messageType=MPAS_LOG_CRIT) - end if - end do - end do + ! + ! Check for NaNs + ! + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + if (ieee_is_nan(w(k,iCell))) then + call mpas_log_write('NaN detected in ''w'' field.', messageType=MPAS_LOG_CRIT) + end if + end do + end do - block => block % next + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + if (ieee_is_nan(u(k,iEdge))) then + call mpas_log_write('NaN detected in ''u'' field.', messageType=MPAS_LOG_CRIT) + end if + end do end do else if (config_print_global_minmax_vel) then call mpas_log_write('') - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - - call mpas_pool_get_array(state, 'w', w, 2) - call mpas_pool_get_array(state, 'u', u, 2) - call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - - scalar_min = 0.0 - scalar_max = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - scalar_min = min(scalar_min, w(k,iCell)) - scalar_max = max(scalar_max, w(k,iCell)) - end do - end do - call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max w $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'w', w, 2) + call mpas_pool_get_array(state, 'u', u, 2) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nEdgesSolve', nEdgesSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - scalar_min = 0.0 - scalar_max = 0.0 - do iEdge = 1, nEdgesSolve - do k = 1, nVertLevels - scalar_min = min(scalar_min, u(k,iEdge)) - scalar_max = max(scalar_max, u(k,iEdge)) - end do - end do - call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write('global min, max u $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) + scalar_min = 0.0 + scalar_max = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, w(k,iCell)) + scalar_max = max(scalar_max, w(k,iCell)) + end do + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + call mpas_log_write('global min, max w $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) - block => block % next + scalar_min = 0.0 + scalar_max = 0.0 + do iEdge = 1, nEdgesSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, u(k,iEdge)) + scalar_max = max(scalar_max, u(k,iEdge)) end do + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + call mpas_log_write('global min, max u $r $r', realArgs=(/global_scalar_min, global_scalar_max/)) end if if (config_print_global_minmax_sca) then @@ -6030,30 +6958,24 @@ subroutine summarize_timestep(domain) call mpas_log_write('') end if - block => domain % blocklist - do while (associated(block)) - call mpas_pool_get_subpool(block % structs, 'state', state) - - call mpas_pool_get_array(state, 'scalars', scalars, 2) - call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) - call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) + call mpas_pool_get_subpool(block % structs, 'state', state) + call mpas_pool_get_array(state, 'scalars', scalars, 2) + call mpas_pool_get_dimension(state, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(state, 'nVertLevels', nVertLevels) + call mpas_pool_get_dimension(state, 'num_scalars', num_scalars) - do iScalar = 1, num_scalars - scalar_min = 0.0 - scalar_max = 0.0 - do iCell = 1, nCellsSolve - do k = 1, nVertLevels - scalar_min = min(scalar_min, scalars(iScalar,k,iCell)) - scalar_max = max(scalar_max, scalars(iScalar,k,iCell)) - end do - end do - call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) - call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) - call mpas_log_write(' global min, max scalar $i $r $r', intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) + do iScalar = 1, num_scalars + scalar_min = 0.0 + scalar_max = 0.0 + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + scalar_min = min(scalar_min, scalars(iScalar,k,iCell)) + scalar_max = max(scalar_max, scalars(iScalar,k,iCell)) end do - - block => block % next + end do + call mpas_dmpar_min_real(domain % dminfo, scalar_min, global_scalar_min) + call mpas_dmpar_max_real(domain % dminfo, scalar_max, global_scalar_max) + call mpas_log_write(' global min, max scalar $i $r $r', intArgs=(/iScalar/), realArgs=(/global_scalar_min, global_scalar_max/)) end do end if diff --git a/src/core_atmosphere/mpas_atm_core.F b/src/core_atmosphere/mpas_atm_core.F index b73cb2a14c..997d7ca8ba 100644 --- a/src/core_atmosphere/mpas_atm_core.F +++ b/src/core_atmosphere/mpas_atm_core.F @@ -10,7 +10,24 @@ module atm_core use mpas_derived_types use mpas_pool_routines use mpas_dmpar - use mpas_log, only : mpas_log_write + use mpas_log, only : mpas_log_write, mpas_log_info + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + + ! + ! 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 type (MPAS_Clock_type), pointer :: clock @@ -26,6 +43,11 @@ function atm_core_init(domain, startTimeStamp) result(ierr) use mpas_atm_dimensions, only : mpas_atm_set_dims use mpas_atm_diagnostics_manager, only : mpas_atm_diag_setup use mpas_atm_threading, only : mpas_atm_threading_init + use atm_time_integration, only : mpas_atm_dynamics_init + use mpas_timer, only : mpas_timer_start, mpas_timer_stop + use mpas_attlist, only : mpas_modify_att + use mpas_string_utils, only : mpas_string_replace + use mpas_atm_halos, only: atm_build_halo_groups, exchange_halo_group implicit none @@ -36,19 +58,25 @@ function atm_core_init(domain, startTimeStamp) result(ierr) real (kind=RKIND), pointer :: dt type (block_type), pointer :: block - character(len=StrKIND) :: timeStamp - integer :: i logical, pointer :: config_do_restart type (mpas_pool_type), pointer :: state type (mpas_pool_type), pointer :: mesh type (mpas_pool_type), pointer :: diag type (field2DReal), pointer :: u_field, pv_edge_field, ru_field, rw_field + type (field0DReal), pointer :: Time_field character (len=StrKIND), pointer :: xtime character (len=StrKIND), pointer :: initial_time1, initial_time2 type (MPAS_Time_Type) :: startTime + real (kind=RKIND), pointer :: nominalMinDc + real (kind=RKIND), pointer :: config_len_disp + real (kind=RKIND), pointer :: Time + integer, pointer :: nVertLevels, maxEdges, maxEdges2, num_scalars + character (len=ShortStrKIND) :: init_stream_name + real (kind=R8KIND) :: input_start_time, input_stop_time + ierr = 0 @@ -76,11 +104,28 @@ function atm_core_init(domain, startTimeStamp) result(ierr) ! Set "local" clock to point to the clock contained in the domain type ! clock => domain % clock + mpas_log_info => domain % logInfo + ! + ! Build halo exchange groups and set method for exchanging halos in a group + ! + call atm_build_halo_groups(domain, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to build halo exchange groups.', messageType=MPAS_LOG_ERR) + return + end if call mpas_pool_get_config(domain % blocklist % configs, 'config_do_restart', config_do_restart) call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', dt) + ! + ! By default, the 'invariant' stream has an input_interval of "none", so + ! the following stream read has no effect. However, in case the 'invariant' + ! stream is defined with an input_interval of "initial_only", we read + ! time-invariant fields first. + ! + call MPAS_stream_mgr_read(domain % streamManager, streamID='invariant', whence=MPAS_STREAM_NEAREST, ierr=ierr) + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='invariant', direction=MPAS_STREAM_INPUT, ierr=ierr) ! ! If this is a restart run, read the restart stream, else read the input @@ -89,18 +134,81 @@ function atm_core_init(domain, startTimeStamp) result(ierr) ! input alarms for both input and restart before reading any remaining ! input streams. ! + call mpas_timer_start('read_ICs') if (config_do_restart) then - call MPAS_stream_mgr_read(domain % streamManager, streamID='restart', ierr=ierr) + init_stream_name = 'restart' else - call MPAS_stream_mgr_read(domain % streamManager, streamID='input', ierr=ierr) + init_stream_name = 'input' end if + call mpas_log_write('Reading initial state from '''//trim(init_stream_name)//''' stream') + + call mpas_dmpar_get_time(input_start_time) + call MPAS_stream_mgr_read(domain % streamManager, streamID=trim(init_stream_name), ierr=ierr) + call mpas_dmpar_get_time(input_stop_time) + call mpas_timer_stop('read_ICs') + if (ierr /= MPAS_STREAM_MGR_NOERR) then call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Error reading initial conditions', messageType=MPAS_LOG_ERR) call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) end if + + call mpas_log_write(' Timing for read of '''//trim(init_stream_name)//''' stream: $r s', & + realArgs=(/real(input_stop_time - input_start_time, kind=RKIND)/)) + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='input', direction=MPAS_STREAM_INPUT, ierr=ierr) call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_INPUT, ierr=ierr) + call mpas_log_write(' ----- done reading initial state -----') + + + ! + ! Determine horizontal length scale used by horizontal diffusion and 3-d divergence damping + ! + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh) + nullify(nominalMinDc) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + + nullify(config_len_disp) + call mpas_pool_get_config(domain % blocklist % configs, 'config_len_disp', config_len_disp) + + call mpas_log_write('') + + ! + ! If config_len_disp was specified as a valid value, use that + ! + if (config_len_disp > 0.0_RKIND) then + call mpas_log_write('Setting nominalMinDc to $r based on namelist option config_len_disp', realArgs=[config_len_disp]) + + ! + ! But if nominalMinDc was available in the input file and is different, print a warning + ! + if (nominalMinDc > 0.0_RKIND .and. abs(nominalMinDc - config_len_disp) > 1.0e-6_RKIND * config_len_disp) then + call mpas_log_write('nominalMinDc was read from input file as a positive value ($r) that differs', & + realArgs=[nominalMinDc], messageType=MPAS_LOG_WARN) + call mpas_log_write('from the specified config_len_disp value ($r)', & + realArgs=[config_len_disp], messageType=MPAS_LOG_WARN) + end if + + nominalMinDc = config_len_disp + + ! + ! Otherwise, try to use nominalMinDc + ! + else + if (nominalMinDc > 0.0_RKIND) then + call mpas_log_write('Setting config_len_disp to $r based on nominalMinDc value in input file', realArgs=[nominalMinDc]) + config_len_disp = nominalMinDc + else + call mpas_log_write('Both config_len_disp and nominalMinDc are <= 0.0.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please either specify config_len_disp in the &nhyd_model namelist group,', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('or use an input file that provides a valid value for the nominalMinDc variable.', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + end if + ! ! Read all other inputs @@ -139,10 +247,7 @@ function atm_core_init(domain, startTimeStamp) result(ierr) startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) call mpas_get_time(startTime, dateTimeString=startTimeStamp) - - call mpas_pool_get_subpool(domain % blocklist % structs, 'state', state) - call mpas_pool_get_field(state, 'u', u_field, 1) - call mpas_dmpar_exch_halo_field(u_field) + call exchange_halo_group(domain, 'initialization:u') ! @@ -172,22 +277,24 @@ function atm_core_init(domain, startTimeStamp) result(ierr) call mpas_pool_get_array(state, 'initial_time', initial_time2, 2) initial_time2 = initial_time1 - block => block % next - end do - - call mpas_pool_get_subpool(domain % blocklist % structs, 'diag', diag) - call mpas_pool_get_field(diag, 'pv_edge', pv_edge_field) - call mpas_dmpar_exch_halo_field(pv_edge_field) + ! 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, '_', ' ')) - call mpas_pool_get_field(diag, 'ru', ru_field) - call mpas_dmpar_exch_halo_field(ru_field) + block => block % next + end do - call mpas_pool_get_field(diag, 'rw', rw_field) - call mpas_dmpar_exch_halo_field(rw_field) + call exchange_halo_group(domain, 'initialization:pv_edge,ru,rw') call mpas_atm_diag_setup(domain % streamManager, domain % blocklist % configs, & domain % blocklist % structs, domain % clock, domain % dminfo) + ! + ! Prepare the dynamics for integration + ! + call mpas_atm_dynamics_init(domain) + end function atm_core_init @@ -201,8 +308,8 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) type (mpas_pool_type), intent(inout) :: configs integer, intent(out) :: ierr - type (MPAS_Time_Type) :: startTime, stopTime, alarmStartTime - type (MPAS_TimeInterval_type) :: runDuration, timeStep, alarmTimeStep + type (MPAS_Time_Type) :: startTime, stopTime + type (MPAS_TimeInterval_type) :: runDuration, timeStep integer :: local_err real (kind=RKIND), pointer :: config_dt character (len=StrKIND), pointer :: config_start_time @@ -210,6 +317,7 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) character (len=StrKIND), pointer :: config_run_duration character (len=StrKIND), pointer :: config_stop_time character (len=StrKIND) :: startTimeStamp + integer :: iounit ierr = 0 @@ -221,9 +329,11 @@ subroutine atm_simulation_clock_init(core_clock, configs, ierr) call mpas_pool_get_config(configs, 'config_stop_time', config_stop_time) if(trim(config_start_time) == 'file') then - open(22,file=trim(config_restart_timestamp_name),form='formatted',status='old') - read(22,*) startTimeStamp - close(22) + call mpas_new_unit(iounit) + open(iounit,file=trim(config_restart_timestamp_name),form='formatted',status='old') + read(iounit,*) startTimeStamp + close(iounit) + call mpas_release_unit(iounit) else startTimeStamp = config_start_time end if @@ -261,6 +371,7 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) use mpas_rbf_interpolation use mpas_vector_reconstruction use mpas_stream_manager + use mpas_atm_boundaries, only : mpas_atm_setup_bdy_masks #ifdef DO_PHYSICS ! use mpas_atmphys_aquaplanet use mpas_atmphys_control @@ -281,7 +392,9 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) type (mpas_pool_type), pointer :: tend type (mpas_pool_type), pointer :: sfc_input type (mpas_pool_type), pointer :: diag_physics + type (mpas_pool_type), pointer :: diag_physics_noahmp type (mpas_pool_type), pointer :: atm_input + type (mpas_pool_type), pointer :: output_noahmp integer :: iCell,iEdge,iVertex @@ -440,14 +553,16 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) !initialization of some input variables in registry: call mpas_pool_get_subpool(block % structs, 'tend', tend) call mpas_pool_get_subpool(block % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block % structs, 'diag_physics_noahmp', diag_physics_noahmp) call mpas_pool_get_subpool(block % structs, 'atm_input', atm_input) + call mpas_pool_get_subpool(block % structs, 'output_noahmp', output_noahmp) call physics_tables_init(dminfo, block % configs) call physics_registry_init(mesh, block % configs, sfc_input) call physics_run_init(block % configs, mesh, state, clock, stream_manager) !initialization of all physics: call physics_init(dminfo, clock, block % configs, mesh, diag, tend, state, 1, diag_physics, & - atm_input, sfc_input) + diag_physics_noahmp, atm_input, sfc_input, output_noahmp) endif #endif @@ -455,6 +570,11 @@ subroutine atm_mpas_init_block(dminfo, stream_manager, block, mesh, dt) call atm_compute_damping_coefs(mesh, block % configs) + ! + ! Set up mask fields used in limited-area simulations + ! + call mpas_atm_setup_bdy_masks(mesh, block % configs) + call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) @@ -473,7 +593,8 @@ function atm_core_run(domain) result(ierr) use mpas_kind_types use mpas_stream_manager use mpas_derived_types, only : MPAS_STREAM_LATEST_BEFORE, MPAS_STREAM_INPUT, MPAS_STREAM_INPUT_OUTPUT - use mpas_timer + use mpas_timer, only : mpas_timer_start, mpas_timer_stop + use mpas_atm_boundaries, only : mpas_atm_update_bdy_tend use mpas_atm_diagnostics_manager, only : mpas_atm_diag_update, mpas_atm_diag_compute, mpas_atm_diag_reset implicit none @@ -483,21 +604,20 @@ function atm_core_run(domain) result(ierr) real (kind=RKIND), pointer :: dt logical, pointer :: config_do_restart + logical, pointer :: config_apply_lbcs type (block_type), pointer :: block_ptr type (MPAS_Time_Type) :: currTime character(len=StrKIND) :: timeStamp character (len=StrKIND), pointer :: config_restart_timestamp_name integer :: itimestep + integer :: iounit integer :: stream_dir character(len=StrKIND) :: input_stream, read_time type (mpas_pool_type), pointer :: state, diag, mesh, diag_physics, tend, tend_physics - ! For high-frequency diagnostics output - character (len=StrKIND) :: tempfilename - ! For timing information real (kind=R8KIND) :: integ_start_time, integ_stop_time real (kind=R8KIND) :: diag_start_time, diag_stop_time @@ -505,6 +625,9 @@ function atm_core_run(domain) result(ierr) real (kind=R8KIND) :: output_start_time, output_stop_time ierr = 0 + + clock => domain % clock + mpas_log_info => domain % logInfo ! Eventually, dt should be domain specific call mpas_pool_get_config(domain % blocklist % configs, 'config_dt', dt) @@ -527,22 +650,28 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call atm_compute_output_diagnostics(state, 1, diag, mesh) block_ptr => block_ptr % next end do end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() call mpas_atm_diag_update() call mpas_atm_diag_compute() + call mpas_timer_stop('diagnostic_fields') call mpas_dmpar_get_time(diag_stop_time) + call mpas_timer_start('stream_output') call mpas_dmpar_get_time(output_start_time) call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_dmpar_get_time(output_stop_time) + call mpas_timer_stop('stream_output') if (ierr /= MPAS_STREAM_MGR_NOERR .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_FILE .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_REC) then @@ -555,7 +684,9 @@ function atm_core_run(domain) result(ierr) call mpas_log_write('Timing for stream output: $r s', realArgs=(/real(output_stop_time - output_start_time, kind=RKIND)/)) end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() + call mpas_timer_stop('diagnostic_fields') call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) @@ -563,7 +694,30 @@ function atm_core_run(domain) result(ierr) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) +#endif + + call mpas_pool_get_config(domain % blocklist % configs, 'config_apply_lbcs', config_apply_lbcs) + + ! + ! Read initial boundary state + ! + if (config_apply_lbcs .and. & + MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_atm_update_bdy_tend(clock, domain % streamManager, block_ptr, .true., ierr) + if (ierr /= 0) then + currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) + call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp) + call mpas_log_write('Failed to process LBC data on or before '//trim(timeStamp), messageType=MPAS_LOG_ERR) + return + end if + + block_ptr => block_ptr % next + end do + end if ! During integration, time level 1 stores the model state at the beginning of the ! time step, and time level 2 stores the state advanced dt in time by timestep(...) @@ -576,6 +730,28 @@ function atm_core_run(domain) result(ierr) call mpas_log_write('') call mpas_log_write('Begin timestep '//trim(timeStamp)) + ! + ! Read future boundary state and compute boundary tendencies + ! + if (config_apply_lbcs .and. & + MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr)) then + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_atm_update_bdy_tend(clock, domain % streamManager, block_ptr, .false., ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to process LBC data at next time after '//trim(timeStamp), messageType=MPAS_LOG_ERR) + return + end if + + block_ptr => block_ptr % next + end do + end if + + ! Regardless of whether boundary tendencies were updated, above, we do not want to read the 'lbc_in' stream + ! as a general input stream, below. + call MPAS_stream_mgr_reset_alarms(domain % streamManager, streamID='lbc_in', direction=MPAS_STREAM_INPUT, ierr=ierr) + + ! ! Read external field updates ! @@ -584,10 +760,12 @@ function atm_core_run(domain) result(ierr) if (stream_dir == MPAS_STREAM_INPUT .or. stream_dir == MPAS_STREAM_INPUT_OUTPUT) then if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID=input_stream, & direction=MPAS_STREAM_INPUT, ierr=ierr)) then + call mpas_timer_start('stream_input') call mpas_dmpar_get_time(input_start_time) call MPAS_stream_mgr_read(domain % streamManager, streamID=input_stream, whence=MPAS_STREAM_LATEST_BEFORE, & actualWhen=read_time, ierr=ierr) call mpas_dmpar_get_time(input_stop_time) + call mpas_timer_stop('stream_input') if (ierr /= MPAS_STREAM_MGR_NOERR) then call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Error reading input stream '//trim(input_stream), messageType=MPAS_LOG_ERR) @@ -632,23 +810,29 @@ function atm_core_run(domain) result(ierr) do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'state', state) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) + call mpas_pool_get_subpool(block_ptr % structs, 'tend_physics', tend_physics) +#endif call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'tend', tend) - call mpas_pool_get_subpool(block_ptr % structs, 'tend_physics', tend_physics) call atm_compute_output_diagnostics(state, 1, diag, mesh) block_ptr => block_ptr % next end do end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_update() call mpas_atm_diag_compute() + call mpas_timer_stop('diagnostic_fields') call mpas_dmpar_get_time(diag_stop_time) + call mpas_timer_start('stream_output') call mpas_dmpar_get_time(output_start_time) call mpas_stream_mgr_write(domain % streamManager, ierr=ierr) call mpas_dmpar_get_time(output_stop_time) + call mpas_timer_stop('stream_output') if (ierr /= MPAS_STREAM_MGR_NOERR .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_FILE .and. & ierr /= MPAS_STREAM_MGR_ERR_CLOBBER_REC) then @@ -667,9 +851,10 @@ function atm_core_run(domain) result(ierr) block_ptr => domain % blocklist do while (associated(block_ptr)) - call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) +#ifdef DO_PHYSICS call mpas_pool_get_subpool(block_ptr % structs, 'diag_physics', diag_physics) - call atm_reset_diagnostics(diag, diag_physics) +#endif + call atm_reset_diagnostics(diag_physics) block_ptr => block_ptr % next end do @@ -680,13 +865,17 @@ function atm_core_run(domain) result(ierr) ! write the restart_timestamp file if (MPAS_stream_mgr_ringing_alarms(domain % streamManager, streamID='restart', direction=MPAS_STREAM_OUTPUT, ierr=ierr)) then if (domain % dminfo % my_proc_id == 0) then - open(22,file=trim(config_restart_timestamp_name),form='formatted',status='replace') - write(22,*) trim(timeStamp) - close(22) + call mpas_new_unit(iounit) + open(iounit,file=trim(config_restart_timestamp_name),form='formatted',status='replace') + write(iounit,*) trim(timeStamp) + close(iounit) + call mpas_release_unit(iounit) end if end if + call mpas_timer_start('diagnostic_fields') call mpas_atm_diag_reset() + call mpas_timer_stop('diagnostic_fields') call mpas_stream_mgr_reset_alarms(domain % streamManager, direction=MPAS_STREAM_OUTPUT, ierr=ierr) @@ -747,27 +936,27 @@ subroutine atm_compute_output_diagnostics(state, time_lev, diag, mesh) end subroutine atm_compute_output_diagnostics - subroutine atm_reset_diagnostics(diag, diag_physics) + subroutine atm_reset_diagnostics(diag_physics) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! reset some diagnostics after output ! - ! Input: diag - contains dynamics diagnostic fields - ! daig_physics - contains physics diagnostic fields + ! Input: diag_physics - contains physics diagnostic fields ! ! Output: whatever diagnostics need resetting after output !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (mpas_pool_type), intent(inout) :: diag - type (mpas_pool_type), intent(inout) :: diag_physics + type (mpas_pool_type), pointer :: diag_physics real (kind=RKIND), dimension(:), pointer :: refl10cm_1km_max +#ifdef DO_PHYSICS call mpas_pool_get_array(diag_physics, 'refl10cm_1km_max', refl10cm_1km_max) if(associated(refl10cm_1km_max)) then refl10cm_1km_max(:) = 0. endif +#endif end subroutine atm_reset_diagnostics @@ -783,6 +972,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 @@ -792,11 +982,13 @@ subroutine atm_do_timestep(domain, dt, itimestep) type (MPAS_Time_Type) :: startTime, currTime type (MPAS_TimeInterval_Type) :: xtimeTime - character(len=StrKIND) :: timeStamp integer :: s, s_n, s_d real (kind=RKIND) :: xtime_s integer :: ierr + clock => domain % clock + mpas_log_info => domain % logInfo + startTime = mpas_get_clock_time(clock, MPAS_START_TIME, ierr) currTime = mpas_get_clock_time(clock, MPAS_NOW, ierr) @@ -804,8 +996,6 @@ subroutine atm_do_timestep(domain, dt, itimestep) call mpas_get_timeInterval(interval=xtimeTime, S=s, S_n=s_n, S_d=s_d, ierr=ierr) xtime_s = (s + s_n / s_d) - call mpas_get_time(curr_time=currTime, dateTimeString=timeStamp, ierr=ierr) - #ifdef DO_PHYSICS !proceed with physics if moist_physics is set to true: @@ -815,7 +1005,7 @@ subroutine atm_do_timestep(domain, dt, itimestep) endif #endif - call atm_timestep(domain, dt, timeStamp, itimestep) + call atm_timestep(domain, dt, currTime, itimestep, exchange_halo_group) end subroutine atm_do_timestep @@ -826,6 +1016,8 @@ function atm_core_finalize(domain) result(ierr) use mpas_timekeeping 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 @@ -839,6 +1031,14 @@ function atm_core_finalize(domain) result(ierr) ierr = 0 + clock => domain % clock + mpas_log_info => domain % logInfo + + ! + ! Finalize the dynamics + ! + call mpas_atm_dynamics_finalize(domain) + call mpas_atm_diag_cleanup() call mpas_destroy_clock(clock, ierr) @@ -853,6 +1053,14 @@ function atm_core_finalize(domain) result(ierr) end do #endif + ! + ! Destroy halo exchange groups + ! + call atm_destroy_halo_groups(domain, ierr) + if (ierr /= 0) then + call mpas_log_write('Failed to destroy halo exchange groups.', messageType=MPAS_LOG_ERR) + end if + ! ! Finalize threading ! @@ -873,18 +1081,22 @@ subroutine atm_compute_mesh_scaling(mesh, configs) type (mpas_pool_type), intent(inout) :: mesh type (mpas_pool_type), intent(in) :: configs - integer :: iEdge, cell1, cell2 - integer, pointer :: nEdges + integer :: iCell,iEdge, cell1, cell2 + integer, pointer :: nEdges, nCells integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: meshDensity, meshScalingDel2, meshScalingDel4 + real (kind=RKIND), dimension(:), pointer :: meshScalingRegionalCell, meshScalingRegionalEdge logical, pointer :: config_h_ScaleWithMesh call mpas_pool_get_array(mesh, 'meshDensity', meshDensity) call mpas_pool_get_array(mesh, 'meshScalingDel2', meshScalingDel2) call mpas_pool_get_array(mesh, 'meshScalingDel4', meshScalingDel4) + call mpas_pool_get_array(mesh, 'meshScalingRegionalCell', meshScalingRegionalCell) + call mpas_pool_get_array(mesh, 'meshScalingRegionalEdge', meshScalingRegionalEdge) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh, 'nCells', nCells) call mpas_pool_get_config(configs, 'config_h_ScaleWithMesh', config_h_ScaleWithMesh) @@ -902,6 +1114,23 @@ subroutine atm_compute_mesh_scaling(mesh, configs) end do end if + ! + ! Compute the scaling factors to be used in relaxation zone of regional configuration + ! + meshScalingRegionalCell(:) = 1.0 + meshScalingRegionalEdge(:) = 1.0 + if (config_h_ScaleWithMesh) then + do iEdge=1,nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + meshScalingRegionalEdge(iEdge) = 1.0 / ( (meshDensity(cell1) + meshDensity(cell2) )/2.0)**0.25 + end do + + do iCell=1,nCells + meshScalingRegionalCell(iCell) = 1.0 / (meshDensity(iCell))**0.25 + end do + end if + end subroutine atm_compute_mesh_scaling @@ -1228,7 +1457,11 @@ end subroutine atm_couple_coef_3rd_order !----------------------------------------------------------------------- subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) +#ifdef DO_PHYSICS use mpas_atmphys_control, only : physics_compatibility_check +#endif + use mpas_atm_boundaries, only : mpas_atm_bdy_checks + use atm_time_integration, only : mpas_atm_dynamics_checks implicit none @@ -1241,13 +1474,27 @@ subroutine mpas_atm_run_compatibility(dminfo, blockList, streamManager, ierr) ierr = 0 - ! Physics specific checks found in /physics/mpas_atmphys_control.F +#ifdef DO_PHYSICS + ! + ! Physics specific checks found in physics/mpas_atmphys_control.F + ! call physics_compatibility_check(dminfo, blockList, streamManager, local_ierr) ierr = ierr + local_ierr +#endif + + ! + ! Checks for limited-area simulations + ! + call mpas_atm_bdy_checks(dminfo, blockList, streamManager, local_ierr) + ierr = ierr + local_ierr + ! + ! Checks for dynamics options + ! + call mpas_atm_dynamics_checks(dminfo, blockList, streamManager, local_ierr) + ierr = ierr + local_ierr end subroutine mpas_atm_run_compatibility - 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 6a9064c60f..c8db24ceac 100644 --- a/src/core_atmosphere/mpas_atm_core_interface.F +++ b/src/core_atmosphere/mpas_atm_core_interface.F @@ -55,7 +55,7 @@ subroutine atm_setup_core(core) core % Conventions = 'MPAS' core % source = 'MPAS' -#include "inc/core_variables.inc" +#include "core_variables.inc" end subroutine atm_setup_core @@ -80,7 +80,7 @@ subroutine atm_setup_domain(domain) type (domain_type), pointer :: domain -#include "inc/domain_variables.inc" +#include "domain_variables.inc" end subroutine atm_setup_domain @@ -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,15 +113,25 @@ 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 logical, pointer :: iauActive character(len=StrKIND), pointer :: config_iau_option + 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 + ! + ! Incremental analysis update + ! nullify(config_iau_option) call mpas_pool_get_config(configs, 'config_IAU_option', config_iau_option) @@ -134,15 +144,68 @@ function atm_setup_packages(configs, packages, iocontext) result(ierr) iauActive = .false. end if + ! + ! Limited-area + ! + nullify(config_apply_lbcs) + call mpas_pool_get_config(configs, 'config_apply_lbcs', config_apply_lbcs) + + nullify(limited_areaActive) + call mpas_pool_get_package(packages, 'limited_areaActive', limited_areaActive) + + if (config_apply_lbcs) then + limited_areaActive = .true. + else + limited_areaActive = .false. + end if + + ! + ! JEDI data assimilation + ! + nullify(config_jedi_da) + call mpas_pool_get_config(configs, 'config_jedi_da', config_jedi_da) + + nullify(jedi_daActive) + call mpas_pool_get_package(packages, 'jedi_daActive', jedi_daActive) + + if (associated(config_jedi_da) .and. associated(jedi_daActive)) then + jedi_daActive = config_jedi_da + else + ierr = ierr + 1 + call mpas_log_write('Package setup failed for ''jedi_da''. '// & + 'Either ''jedi_da'' is not a package, or ''config_jedi_da'' is not a namelist option.', & + 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): call physics_namelist_check(configs) - ierr = atmphys_setup_packages(configs,packages,iocontext) - if(ierr /= 0) then + local_ierr = atmphys_setup_packages(configs, packages, iocontext) + if (local_ierr /= 0) then + ierr = ierr + 1 call mpas_log_write('Package setup failed for atmphys in core_atmosphere', messageType=MPAS_LOG_ERR) - endif + end if #endif end function atm_setup_packages @@ -195,15 +258,17 @@ end function atm_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function atm_setup_log(logInfo, domain) result(iErr)!{{{ + function atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open + use mpas_framework, only : mpas_framework_report_settings implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -212,7 +277,7 @@ function atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -224,13 +289,11 @@ function atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = ior(iErr, local_err) call mpas_log_write('') -#ifdef SINGLE_PRECISION - call mpas_log_write('Using default single-precision reals') -#else - call mpas_log_write('Using default double-precision reals') -#endif + call mpas_log_write('MPAS-Atmosphere Version '//trim(domain % core % modelVersion)) call mpas_log_write('') + call mpas_framework_report_settings(domain) + end function atm_setup_log!}}} @@ -248,22 +311,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 @@ -333,29 +410,186 @@ end function atm_setup_decompositions function atm_setup_block(block) result(ierr) use mpas_derived_types, only : block_type + use mpas_pool_routines, only : mpas_pool_get_config + use mpas_log, only : mpas_log_write implicit none type (block_type), pointer :: block integer :: ierr + integer, pointer :: cam_pcnst + integer :: err_level + ierr = 0 call atm_generate_structs(block, block % structs, block % dimensions, block % packages) + ! + ! When MPAS-A is operating as a dycore in CAM, the scalars/scalars_tend var_arrays are + ! allocated by the call to atm_allocate_scalars, below. The CAM-MPAS interface layer + ! should have added a config, cam_pcnst, to the configs pool to indicate how many scalars + ! are to be allocated. + ! + nullify(cam_pcnst) + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + call mpas_pool_get_config(block % domain % configs, 'cam_pcnst', cam_pcnst) + call mpas_pool_set_error_level(err_level) + if (associated(cam_pcnst)) then + call mpas_log_write('') + call mpas_log_write('** Config ''cam_pcnst'' is defined with a value of $i', intArgs=[cam_pcnst]) + call mpas_log_write(' Scalars will be allocated separately from Registry-defined variables') + call mpas_log_write('') + ierr = atm_allocate_scalars(block, cam_pcnst) + end if + end function atm_setup_block -#include "inc/setup_immutable_streams.inc" + !*********************************************************************** + ! + ! function atm_allocate_scalars + ! + !> \brief Allocate scalars and scalars_tend var_arrays + !> \author Michael G. Duda + !> \date 20 May 2020 + !> \details + !> When MPAS-A is operating as a dycore for CAM, the scalars and + !> scalars_tend var_arrays are allocated separately from other Registry- + !> defined variables, since the set of scalars to be handled by the dycore + !> is not known until runtime. This routine allocates these var_arrays, + !> but it does not define which constituent is at which position in + !> var_arrays; this is defined later in the CAM-MPAS interface layer. + ! + !----------------------------------------------------------------------- + function atm_allocate_scalars(block, num_scalars) result(ierr) + + use mpas_derived_types, only : block_type + + use mpas_derived_types, only : mpas_pool_type, field3dReal, MPAS_LOG_ERR + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_add_dimension, mpas_pool_add_field + use mpas_log, only : mpas_log_write + + implicit none + + ! Arguments + type (block_type), pointer :: block + integer, intent(in) :: num_scalars + + ! Return value + integer :: ierr + + ! Local variables + integer :: i, j, timeLevs + type (mpas_pool_type), pointer :: statePool + type (mpas_pool_type), pointer :: tendPool + type (field3dReal), dimension(:), pointer :: scalarsField + + + ierr = 0 + + ! + ! Allocate scalars var_array + ! + nullify(statePool) + call mpas_pool_get_subpool(block % structs, 'state', statePool) + + if (.not. associated(statePool)) then + call mpas_log_write('No pool named ''state'' was found in atm_allocate_scalars', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + timeLevs = 2 + + call mpas_pool_add_dimension(statePool, 'num_scalars', num_scalars) + + allocate(scalarsField(timeLevs)) + + do i = 1, timeLevs + scalarsField(i) % block => block + scalarsField(i) % fieldName = 'scalars' + scalarsField(i) % dimNames(1) = 'num_scalars' + scalarsField(i) % dimNames(2) = 'nVertLevels' + scalarsField(i) % dimNames(3) = 'nCells' + scalarsField(i) % defaultValue = 0.0 + scalarsField(i) % missingValue = -1.0 + scalarsField(i) % isDecomposed = .true. + scalarsField(i) % hasTimeDimension = .true. + scalarsField(i) % isActive = .true. + scalarsField(i) % isVarArray = .true. + scalarsField(i) % isPersistent = .true. + + allocate(scalarsField(i) % constituentNames(num_scalars)) + + allocate(scalarsField(i) % attLists(num_scalars)) + do j = 1, num_scalars + allocate(scalarsField(i) % attLists(j) % attList) + end do + + end do + + call mpas_pool_add_field(statePool, 'scalars', scalarsField) + call mpas_pool_add_field(block % allFields, 'scalars', scalarsField) + + + ! + ! Allocate scalars_tend var_array + ! + nullify(tendPool) + call mpas_pool_get_subpool(block % structs, 'tend', tendPool) + + if (.not. associated(tendPool)) then + call mpas_log_write('No pool named ''tend'' was found in atm_allocate_scalars', messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + timeLevs = 1 + + call mpas_pool_add_dimension(tendPool, 'num_scalars_tend', num_scalars) + + allocate(scalarsField(timeLevs)) + + do i = 1, timeLevs + scalarsField(i) % block => block + scalarsField(i) % fieldName = 'scalars_tend' + scalarsField(i) % dimNames(1) = 'num_scalars_tend' + scalarsField(i) % dimNames(2) = 'nVertLevels' + scalarsField(i) % dimNames(3) = 'nCells' + scalarsField(i) % defaultValue = 0.0 + scalarsField(i) % missingValue = -1.0 + scalarsField(i) % isDecomposed = .true. + scalarsField(i) % hasTimeDimension = .true. + scalarsField(i) % isActive = .true. + scalarsField(i) % isVarArray = .true. + scalarsField(i) % isPersistent = .true. + + allocate(scalarsField(i) % constituentNames(num_scalars)) + + allocate(scalarsField(i) % attLists(num_scalars)) + do j = 1, num_scalars + allocate(scalarsField(i) % attLists(j) % attList) + end do + + end do + + call mpas_pool_add_field(tendPool, 'scalars_tend', scalarsField) + call mpas_pool_add_field(block % allFields, 'scalars_tend', scalarsField) + + end function atm_allocate_scalars + +#include "setup_immutable_streams.inc" -#include "inc/block_dimension_routines.inc" +#include "block_dimension_routines.inc" -#include "inc/define_packages.inc" +#include "define_packages.inc" -#include "inc/structs_and_variables.inc" +#include "structs_and_variables.inc" -#include "inc/namelist_call.inc" +#include "namelist_call.inc" -#include "inc/namelist_defines.inc" +#include "namelist_defines.inc" end module atm_core_interface diff --git a/src/core_atmosphere/mpas_atm_halos.F b/src/core_atmosphere/mpas_atm_halos.F new file mode 100644 index 0000000000..df02ee30a2 --- /dev/null +++ b/src/core_atmosphere/mpas_atm_halos.F @@ -0,0 +1,455 @@ +! 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 + + 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 + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, intent(inout) :: ierr + + ! Local variables + character(len=StrKIND), pointer :: config_halo_exch_method + + + ! + ! 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 + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, intent(inout) :: ierr + + ! Local variables + character(len=StrKIND), pointer :: config_halo_exch_method + + + 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 + ! + ! 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/.gitignore b/src/core_atmosphere/physics/.gitignore index e0d3d1a002..f27a16f144 100644 --- a/src/core_atmosphere/physics/.gitignore +++ b/src/core_atmosphere/physics/.gitignore @@ -1,3 +1,4 @@ *.f90 physics_wrf/*.f90 physics_wrf/files/ +physics_mmm diff --git a/src/core_atmosphere/physics/Makefile b/src/core_atmosphere/physics/Makefile index 8e9abfcedb..a0ffde0a4f 100644 --- a/src/core_atmosphere/physics/Makefile +++ b/src/core_atmosphere/physics/Makefile @@ -4,15 +4,18 @@ ifeq ($(CORE),atmosphere) COREDEF = -Dmpas endif -all: lookup_tables core_physics_init core_physics_wrf core_physics +all: + ./../tools/manage_externals/checkout_externals --externals ./../Externals.cfg + $(MAKE) lookup_tables core_physics_init core_physics_mmm core_physics_wrf core_physics_noahmp core_physics dummy: echo "****** compiling physics ******" OBJS_init = \ - mpas_atmphys_constants.o \ - mpas_atmphys_date_time.o \ - mpas_atmphys_functions.o \ + ccpp_kind_types.o \ + mpas_atmphys_constants.o \ + mpas_atmphys_date_time.o \ + mpas_atmphys_functions.o \ mpas_atmphys_utilities.o OBJS = \ @@ -23,11 +26,13 @@ OBJS = \ mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ + mpas_atmphys_driver_lsm_noahmp.o \ mpas_atmphys_driver_microphysics.o \ mpas_atmphys_driver_oml.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_finalize.o \ mpas_atmphys_init.o \ @@ -35,6 +40,9 @@ OBJS = \ mpas_atmphys_interface.o \ mpas_atmphys_landuse.o \ mpas_atmphys_lsm_noahinit.o \ + mpas_atmphys_lsm_noahmpinit.o \ + mpas_atmphys_lsm_noahmpfinalize.o \ + mpas_atmphys_lsm_shared.o \ mpas_atmphys_manager.o \ mpas_atmphys_o3climatology.o \ mpas_atmphys_packages.o \ @@ -48,15 +56,27 @@ OBJS = \ lookup_tables: ./checkout_data_files.sh -core_physics_wrf: core_physics_init +core_physics_mmm: core_physics_init + (cd physics_mmm; $(MAKE) -f Makefile.mpas all) + +core_physics_wrf: core_physics_init core_physics_mmm (cd physics_wrf; $(MAKE) all COREDEF="$(COREDEF)") +core_physics_noahmp: + (cd physics_noahmp/utility; $(MAKE) all COREDEF="$(COREDEF)") + (cd physics_noahmp/src; $(MAKE) all COREDEF="$(COREDEF)") + (cd physics_noahmp/drivers/mpas; $(MAKE) all COREDEF="$(COREDEF)") + core_physics_init: $(OBJS_init) - ar -ru libphys.a $(OBJS_init) -core_physics: core_physics_wrf +core_physics: core_physics_wrf core_physics_noahmp ($(MAKE) phys_interface COREDEF="$(COREDEF)") - ar -ru libphys.a $(OBJS) + ar -ru libphys.a $(OBJS_init) $(OBJS) + ($(MAKE) -C ./physics_mmm -f Makefile.mpas physics_mmm_lib) + ($(MAKE) -C ./physics_wrf physics_wrf_lib) + ($(MAKE) -C ./physics_noahmp/drivers/mpas driver_lib) + ($(MAKE) -C ./physics_noahmp/src src_lib) + ($(MAKE) -C ./physics_noahmp/utility utility_lib) phys_interface: $(OBJS) @@ -74,9 +94,11 @@ mpas_atmphys_driver.o: \ mpas_atmphys_driver_convection.o \ mpas_atmphys_driver_gwdo.o \ mpas_atmphys_driver_lsm.o \ + mpas_atmphys_driver_lsm_noahmp.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 \ @@ -102,6 +124,11 @@ mpas_atmphys_driver_lsm.o: \ mpas_atmphys_lsm_noahinit.o \ mpas_atmphys_vars.o +mpas_atmphys_driver_lsm_noahmp.o: \ + mpas_atmphys_constants.o \ + mpas_atmphys_manager.o \ + mpas_atmphys_vars.o + mpas_atmphys_driver_microphysics.o: \ mpas_atmphys_constants.o \ mpas_atmphys_init_microphysics.o \ @@ -132,19 +159,30 @@ mpas_atmphys_driver_radiation_sw.o: \ mpas_atmphys_rrtmg_swinit.o \ mpas_atmphys_vars.o +mpas_atmphys_driver_seaice.o: \ + mpas_atmphys_constants.o \ + mpas_atmphys_lsm_shared.o \ + mpas_atmphys_vars.o + mpas_atmphys_driver_sfclayer.o: \ mpas_atmphys_constants.o \ mpas_atmphys_vars.o +mpas_atmphys_finalize.o: \ + mpas_atmphys_lsm_noahmpfinalize.o + 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_lsm_noahmpinit.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 \ @@ -158,6 +196,13 @@ mpas_atmphys_lsm_noahinit.o: \ mpas_atmphys_constants.o \ mpas_atmphys_utilities.o +mpas_atmphys_lsm_noahmpinit.o: \ + mpas_atmphys_utilities.o \ + mpas_atmphys_vars.o + +mpas_atmphys_lsm_noahmpfinalize.o : \ + mpas_atmphys_vars.o + mpas_atmphys_manager.o: \ mpas_atmphys_constants.o \ mpas_atmphys_o3climatology.o \ @@ -185,7 +230,6 @@ mpas_atmphys_todynamics.o: \ mpas_atmphys_update_surface.o: \ mpas_atmphys_date_time.o \ mpas_atmphys_constants.o \ - mpas_atmphys_landuse.o \ mpas_atmphys_vars.o mpas_atmphys_update.o: \ @@ -195,6 +239,10 @@ mpas_atmphys_update.o: \ clean: $(RM) *.o *.mod *.f90 libphys.a ( cd physics_wrf; $(MAKE) clean ) + ( if [ -d physics_mmm ]; then cd physics_mmm; $(MAKE) -f Makefile.mpas clean; fi; ) + ( cd physics_noahmp/drivers/mpas; $(MAKE) clean ) + ( cd physics_noahmp/src; $(MAKE) clean ) + ( cd physics_noahmp/utility; $(MAKE) clean ) @# Certain systems with intel compilers generate *.i files @# This removes them during the clean process $(RM) *.i @@ -203,7 +251,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(HYDROSTATIC) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_wrf -I.. -I../../framework -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(HYDROSATIC) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./physics_mmm -I./physics_wrf -I./physics_noahmp -I./physics_noahmp/utility -I./physics_noahmp/drivers/mpas -I./physics_noahmp/src -I.. -I../../framework -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/physics/Registry_noahmp.xml b/src/core_atmosphere/physics/Registry_noahmp.xml new file mode 100644 index 0000000000..2e489d442c --- /dev/null +++ b/src/core_atmosphere/physics/Registry_noahmp.xml @@ -0,0 +1,624 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/core_atmosphere/physics/ccpp_kind_types.F b/src/core_atmosphere/physics/ccpp_kind_types.F new file mode 100644 index 0000000000..cdc75ccfa8 --- /dev/null +++ b/src/core_atmosphere/physics/ccpp_kind_types.F @@ -0,0 +1,4 @@ +module ccpp_kind_types + use mpas_kind_types,only: kind_phys => RKIND, kind_phys8 => R8KIND + contains +end module ccpp_kind_types diff --git a/src/core_atmosphere/physics/checkout_data_files.sh b/src/core_atmosphere/physics/checkout_data_files.sh index e62b466aa7..b5ad45bcef 100755 --- a/src/core_atmosphere/physics/checkout_data_files.sh +++ b/src/core_atmosphere/physics/checkout_data_files.sh @@ -5,64 +5,94 @@ # # The purpose of this script is to obtain lookup tables used by the WRF physics # packages. At present, the only method for acquiring these tables is through -# the MPAS-Dev github repository using either git, svn, or curl. +# the MPAS-Dev GitHub repository using either git, svn, or curl. # # If none of the methods used in this script are successful in acquiring the # tables, please attempt to manually download the files from the MPAS-Data # repository at https://github.com/MPAS-Dev/MPAS-Data/. All *.TBL and *DATA* # files, as well as the COMPATIBILITY file, should be copied into # a subdirectory named src/core_atmosphere/physics/physics_wrf/files before -# continuing the build process. +# continuing the build process. In general, one should obtain the lookup +# tables from a tag in the MPAS-Dev repository whose name matches the version +# of the MPAS-Atmosphere code; e.g., for MPAS-Atmosphere v7.0, one should +# use the tables from the v7.0 tag in the MPAS-Data repository. # -# If all else fails, please contact the MPAS-A developers -# via "mpas-atmosphere-help@googlegroups.com". +# If all else fails, please contact the MPAS-Atmosphere developers through +# the MPAS-Atmosphere support forum at http://forum.mmm.ucar.edu/. # ################################################################################ -mpas_vers="4.0" -if [ -s physics_wrf/files/COMPATIBILITY ]; then +mpas_vers="8.2" - compatible=0 +github_org="MPAS-Dev" # GitHub organization where the MPAS-Data repository is found. + # For physics development, it can be helpful for a developer + # to obtain tables from their own fork of the MPAS-Data repository. - compat=`cat physics_wrf/files/COMPATIBILITY | grep -v "#"` - for ver in $compat; do - if [ "$ver" = "$mpas_vers" ]; then - compatible=1 +# +# Return 1 if the "mpas_vers" string is found in the physics table COMPATIBILITY +# file, and 0 otherwise +# +check_compatibility() { + for ver in `cat physics_wrf/files/COMPATIBILITY | grep -v "#"`; do + if [ "${ver}" = "${mpas_vers}" ]; then + return 1 fi done + return 0 +} + + +# +# See whether we already have compatible physics tables +# +if [ -s physics_wrf/files/COMPATIBILITY ]; then - if [ $compatible -eq 1 ]; then + check_compatibility + if [ $? -eq 1 ]; then echo "*** Compatible versions of WRF physics tables appear to already exist; no need to obtain them again ***" exit 0 else - echo "*** Existing WRF physics tables appear to be incompatible with MPAS v$mpas_vers; downloading the latest tables ***" + echo "*** Existing WRF physics tables appear to be incompatible with MPAS v${mpas_vers}; attempting to download compatible tables ***" fi else - echo "*** No compatible version of WRF physics tables found; downloading the latest tables ***" + echo "*** No compatible version of WRF physics tables found; attempting to download compatible tables ***" fi - if [ ! -d physics_wrf/files ]; then mkdir -p physics_wrf/files fi + # # Try using 'git' # which git if [ $? -eq 0 ]; then - echo "*** trying git to obtain WRF physics tables ***" - git clone git://github.com/MPAS-Dev/MPAS-Data.git + echo "*** Trying git to obtain WRF physics tables ***" + git clone https://github.com/${github_org}/MPAS-Data.git if [ $? -eq 0 ]; then + cd MPAS-Data + git checkout v${mpas_vers} + if [ $? -ne 0 ]; then + echo "*** MPAS version-specific tag not found; trying the master branch ***" + else + echo "*** Found v${mpas_vers} tag ***" + fi + cd .. mv MPAS-Data/atmosphere/physics_wrf/files/* physics_wrf/files rm -rf MPAS-Data - exit 0 + + check_compatibility + if [ $? -eq 1 ]; then + echo "*** Successfully obtained compatible versions of WRF physics tables ***" + exit 0 + fi else - echo "*** failed to obtain WRF physics tables using git ***" + echo "*** Failed to obtain WRF physics tables using git ***" fi else echo "*** git not in path ***" @@ -74,14 +104,26 @@ fi # which svn if [ $? -eq 0 ]; then - echo "*** trying svn to obtain WRF physics tables ***" - svn checkout --non-interactive --trust-server-cert https://github.com/MPAS-Dev/MPAS-Data.git + echo "*** Trying svn to obtain WRF physics tables ***" + branch=v${mpas_vers} + svn checkout --non-interactive --trust-server-cert https://github.com/${github_org}/MPAS-Data.git/tags/${branch} + if [ $? -ne 0 ]; then + echo "*** MPAS version-specific tag not found; trying the trunk ***" + branch=trunk + svn checkout --non-interactive --trust-server-cert https://github.com/${github_org}/MPAS-Data.git/${branch} + else + echo "*** Found v${mpas_vers} tag ***" + fi if [ $? -eq 0 ]; then - mv MPAS-Data.git/trunk/atmosphere/physics_wrf/files/* physics_wrf/files - rm -rf MPAS-Data.git - exit 0 + mv ${branch}/atmosphere/physics_wrf/files/* physics_wrf/files + rm -rf ${branch} + check_compatibility + if [ $? -eq 1 ]; then + echo "*** Successfully obtained compatible versions of WRF physics tables ***" + exit 0 + fi else - echo "*** failed to obtain WRF physics tables using svn ***" + echo "*** Failed to obtain WRF physics tables using svn ***" fi else echo "*** svn not in path ***" @@ -93,21 +135,34 @@ fi # which curl if [ $? -eq 0 ]; then - echo "*** trying curl to obtain WRF physics tables ***" - curl -o master.zip https://codeload.github.com/MPAS-Dev/MPAS-Data/zip/master + echo "*** Trying curl to obtain WRF physics tables ***" + branch=${mpas_vers} + curl -sf -o MPAS-Data.tar.gz https://codeload.github.com/${github_org}/MPAS-Data/tar.gz/v${branch} + if [ $? -ne 0 ]; then + echo "*** MPAS version-specific tar file not found; trying the master tar file ***" + branch=master + curl -sf -o MPAS-Data.tar.gz https://codeload.github.com/${github_org}/MPAS-Data/tar.gz/${branch} + else + echo "*** Found v${mpas_vers} tar file ***" + fi if [ $? -eq 0 ]; then - which unzip + which tar if [ $? -eq 0 ]; then - unzip master.zip - mv MPAS-Data-master/atmosphere/physics_wrf/files/* physics_wrf/files - rm -rf master.zip MPAS-Data-master - exit 0 + tar -xzf MPAS-Data.tar.gz + mv MPAS-Data-${branch}/atmosphere/physics_wrf/files/* physics_wrf/files + rm -rf MPAS-Data.tar.gz MPAS-Data-${branch} + + check_compatibility + if [ $? -eq 1 ]; then + echo "*** Successfully obtained compatible versions of WRF physics tables ***" + exit 0 + fi else - echo "*** unzip not in path -- unable to unzip WRF physics tables" - rm -f master.zip + echo "*** tar not in path -- unable to extract WRF physics tables ***" + rm -rf MPAS-Data.tar.gz fi else - echo "*** failed to obtain WRF physics tables using curl ***" + echo "*** Failed to obtain WRF physics tables using curl ***" fi else echo "*** curl not in path ***" diff --git a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F index e2c8aabcf8..48cb5a4413 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_camrad_init.F @@ -16,6 +16,7 @@ module mpas_atmphys_camrad_init use mpas_dmpar use mpas_kind_types use mpas_pool_routines + use mpas_io_units use mpas_atmphys_constants,only: cp,degrad,ep_2,gravity,R_d,R_v,stbolt use mpas_atmphys_utilities @@ -298,7 +299,6 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) real(r8):: tdbl integer:: i,istat,cam_abs_unit - logical:: opened character(len=StrKIND):: errmess integer:: i_te,i_rh @@ -330,16 +330,9 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) fwc2 = 4.5 ! See eq(33) and eq(34) in R&D fc1 = 2.6 ! See eq(34) R&D - istat = -999 if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened) then - cam_abs_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(cam_abs_unit, unformatted = .true.) + if(cam_abs_unit < 0) & call physics_error_fatal('module_ra_cam: radaeinit: Cannot find unused '//& 'fortran unit to read in lookup table.') endif @@ -375,7 +368,10 @@ subroutine radaeini(dminfo,pstdx,mwdryx,mwco2x) DM_BCAST_MACRO(ln_ah2ow) DM_BCAST_MACRO(ln_eh2ow) - if(dminfo % my_proc_id == IO_NODE) close(cam_abs_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(cam_abs_unit) + call mpas_release_unit(cam_abs_unit) + end if ! Set up table of H2O saturation vapor pressures for use in calculation effective path RH. ! Need separate table from table in wv_saturation because: @@ -595,7 +591,6 @@ subroutine aer_optics_initialize(dminfo) real(r8):: dummy(nspint) integer:: i,istat,cam_aer_unit - logical:: opened character(len=StrKIND):: errmess !----------------------------------------------------------------------------------------------------------------- @@ -603,16 +598,9 @@ subroutine aer_optics_initialize(dminfo) !call mpas_log_write('--- enter subroutine aer_optics_initialize:') !READ AEROSOL OPTICS DATA: - istat = -999 if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened) then - cam_aer_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(cam_aer_unit, unformatted = .true.) + if(cam_aer_unit < 0) & call physics_error_fatal('module_ra_cam: aer_optics_initialize: Cannot find unused '//& 'fortran unit to read in lookup table.') endif @@ -685,7 +673,10 @@ subroutine aer_optics_initialize(dminfo) DM_BCAST_MACRO(wvolc) DM_BCAST_MACRO(gvolc) - if(dminfo % my_proc_id == IO_NODE) close(cam_aer_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(cam_aer_unit) + call mpas_release_unit(cam_aer_unit) + end if ! map OPAC aerosol species onto CAM aerosol species ! CAM name OPAC name @@ -764,9 +755,7 @@ subroutine oznini(mesh,atm_input) real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: - integer,parameter:: pin_unit = 27 - integer,parameter:: lat_unit = 28 - integer,parameter:: oz_unit = 29 + integer:: read_unit integer,parameter:: open_ok = 0 integer:: i,i1,i2,istat,k,j,m @@ -789,30 +778,35 @@ subroutine oznini(mesh,atm_input) call mpas_pool_get_array(atm_input,'ozmixm',ozmixm) !-- read in ozone pressure data: - open(pin_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) + call mpas_new_unit(read_unit) + if(read_unit < 0) & + call physics_error_fatal('module_ra_cam: oznini: Cannot find unused '//& + 'fortran unit to read in lookup table.') + + open(read_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & 'failure opening OZONE_PLEV.TBL') do k = 1,levsiz - read(pin_unit,*) pin(k) + read(read_unit,*) pin(k) pin(k) = pin(k)*100. ! call mpas_log_write('$r', realArgs=(/pin(k)/)) enddo - close(pin_unit) + close(read_unit) !-- read in ozone lat data: - open(lat_unit, file='OZONE_LAT.TBL',action='READ',status='OLD',iostat=istat) + open(read_unit, file='OZONE_LAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & 'failure opening OZONE_LAT.TBL') do j = 1, latsiz - read(lat_unit,*) lat_ozone(j) + read(read_unit,*) lat_ozone(j) ! call mpas_log_write('$i $r', intArgs=(/j/), realArgs=(/lat_ozone(j)/)) enddo - close(lat_unit) + close(read_unit) !-- read in ozone data: - open(oz_unit,file='OZONE_DAT.TBL',action='READ',status='OLD',iostat=istat) + open(read_unit,file='OZONE_DAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & 'failure opening OZONE_DAT.TBL') @@ -822,12 +816,14 @@ subroutine oznini(mesh,atm_input) do j=1,latsiz ! latsiz=64 do k=1,levsiz ! levsiz=59 do i=1,lonsiz ! lonsiz=1 - read(oz_unit,*) ozmixin(i,k,j,m) + read(read_unit,*) ozmixin(i,k,j,m) enddo enddo enddo enddo - close(oz_unit) + close(read_unit) + + call mpas_release_unit(read_unit) !INTERPOLATION OF INPUT OZONE DATA TO MPAS GRID: !call mpas_log_write('max latCell= $r', realArgs=(/maxval(latCell)/degrad/)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_constants.F b/src/core_atmosphere/physics/mpas_atmphys_constants.F index 12433a699b..65270f78f8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_constants.F +++ b/src/core_atmosphere/physics/mpas_atmphys_constants.F @@ -75,6 +75,14 @@ module mpas_atmphys_constants real(kind=RKIND),parameter:: epsilon = 1.e-15 real(kind=RKIND),parameter:: psat = 610.78 + real(kind=RKIND),parameter:: re_qc_bg = 2.49e-6 ! effective radius of cloud water for background (m) + real(kind=RKIND),parameter:: re_qi_bg = 4.99e-6 ! effective radius of cloud ice for background (m) + real(kind=RKIND),parameter:: re_qs_bg = 9.99e-6 ! effective radius of snow for background (m) + + real(kind=RKIND),parameter:: re_qc_max = 50.e-6 ! maximum effective radius of cloud water (m) + real(kind=RKIND),parameter:: re_qi_max = 125.e-6 ! maximum effective radius of cloud ice (m) + real(kind=RKIND),parameter:: re_qs_max = 999.e-6 ! maximum radius of snow (m) + !constants specific to long- and short-wave radiation codes: !real(kind=RKIND),parameter:: solcon_0 = 1365. !solar constant [W/m2] real(kind=RKIND),parameter:: solcon_0 = 1370. !solar constant [W/m2] diff --git a/src/core_atmosphere/physics/mpas_atmphys_control.F b/src/core_atmosphere/physics/mpas_atmphys_control.F index 9b7a08c5e0..5c77875911 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_control.F +++ b/src/core_atmosphere/physics/mpas_atmphys_control.F @@ -72,6 +72,17 @@ module mpas_atmphys_control ! * modified logic in subroutine physics_tables_init so that the Thompson microphysics tables are read in each ! MPI task. ! Laura D. Fowler (laura@ucar.edu) / 2016-12-30. +! * added the option mp_thompson_aerosols. +! Laura D. Fowler (laura@ucar.edu) / 2018-01-31. +! * 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. +! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. +! * added the option "sf_noahmp" to run the NOAH-MP land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-07-15. +! * in the mesoscale_reference suite, replaced the MM5 surface layer scheme with the MM5 revised surface layer +! scheme as the default option for config_sfclayer_scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-06-18. contains @@ -126,8 +137,8 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_lw_scheme) == 'suite') config_radt_lw_scheme = 'rrtmg_lw' if (trim(config_radt_sw_scheme) == 'suite') config_radt_sw_scheme = 'rrtmg_sw' if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' - if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov' - if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'noah' + if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_monin_obukhov_rev' + if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' else if (trim(config_physics_suite) == 'convection_permitting') then @@ -139,7 +150,7 @@ subroutine physics_namelist_check(configs) if (trim(config_radt_sw_scheme) == 'suite') config_radt_sw_scheme = 'rrtmg_sw' if (trim(config_radt_cld_scheme) == 'suite') config_radt_cld_scheme = 'cld_fraction' if (trim(config_sfclayer_scheme) == 'suite') config_sfclayer_scheme = 'sf_mynn' - if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'noah' + if (trim(config_lsm_scheme) == 'suite') config_lsm_scheme = 'sf_noah' else if (trim(config_physics_suite) == 'none') then @@ -162,12 +173,13 @@ subroutine physics_namelist_check(configs) end if !cloud microphysics scheme: - if(.not. (config_microp_scheme .eq. 'off' .or. & - config_microp_scheme .eq. 'mp_kessler' .or. & - config_microp_scheme .eq. 'mp_thompson' .or. & + if(.not. (config_microp_scheme .eq. 'off' .or. & + config_microp_scheme .eq. 'mp_kessler' .or. & + config_microp_scheme .eq. 'mp_thompson' .or. & + config_microp_scheme .eq. 'mp_thompson_aerosols' .or. & config_microp_scheme .eq. 'mp_wsm6')) then - write(mpas_err_message,'(A,A10)') 'illegal value for config_microp_scheme:', & + write(mpas_err_message,'(A,A20)') 'illegal value for config_microp_scheme:', & trim(config_microp_scheme) call physics_error_fatal(mpas_err_message) @@ -180,7 +192,7 @@ subroutine physics_namelist_check(configs) config_convection_scheme .eq. 'cu_tiedtke' .or. & config_convection_scheme .eq. 'cu_ntiedtke')) then - write(mpas_err_message,'(A,A10)') 'illegal value for config_convection_scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for config_convection_scheme: ', & trim(config_convection_scheme) call physics_error_fatal(mpas_err_message) @@ -191,7 +203,7 @@ subroutine physics_namelist_check(configs) config_pbl_scheme .eq. 'bl_mynn' .or. & config_pbl_scheme .eq. 'bl_ysu')) then - write(mpas_err_message,'(A,A10)') 'illegal value for pbl_scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for pbl_scheme: ', & trim(config_pbl_scheme) call physics_error_fatal(mpas_err_message) @@ -201,7 +213,7 @@ subroutine physics_namelist_check(configs) if(.not. (config_gwdo_scheme .eq. 'off' .or. & config_gwdo_scheme .eq. 'bl_ysu_gwdo')) then - write(mpas_err_message,'(A,A10)') 'illegal value for gwdo_scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for gwdo_scheme: ', & trim(config_gwdo_scheme) call physics_error_fatal(mpas_err_message) @@ -212,7 +224,7 @@ subroutine physics_namelist_check(configs) config_radt_lw_scheme .eq. 'cam_lw' .or. & config_radt_lw_scheme .eq. 'rrtmg_lw')) then - write(mpas_err_message,'(A,A10)') 'illegal value for longwave radiation scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for longwave radiation scheme: ', & trim(config_radt_lw_scheme) call physics_error_fatal(mpas_err_message) @@ -223,7 +235,7 @@ subroutine physics_namelist_check(configs) config_radt_sw_scheme .eq. 'cam_sw' .or. & config_radt_sw_scheme .eq. 'rrtmg_sw')) then - write(mpas_err_message,'(A,A10)') 'illegal value for shortwave radiation _scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for shortwave radiation _scheme: ', & trim(config_radt_sw_scheme) call physics_error_fatal(mpas_err_message) @@ -235,7 +247,7 @@ subroutine physics_namelist_check(configs) config_radt_cld_scheme .eq. 'cld_fraction' .or. & config_radt_cld_scheme .eq. 'cld_fraction_thompson')) then - write(mpas_err_message,'(A,A10)') 'illegal value for calculation of cloud fraction: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for calculation of cloud fraction: ', & trim(config_radt_cld_scheme) call physics_error_fatal(mpas_err_message) @@ -244,10 +256,10 @@ subroutine physics_namelist_check(configs) (config_radt_sw_scheme.ne.'off' .and. config_radt_cld_scheme.eq.'off')) then call mpas_log_write('') - write(mpas_err_message,'(A,A10)') & + write(mpas_err_message,'(A,A20)') & ' config_radt_cld_scheme is not set for radiation calculation' call physics_message(mpas_err_message) - write(mpas_err_message,'(A,A10)') & + write(mpas_err_message,'(A,A20)') & ' switch calculation of cloud fraction to config_radt_cld_scheme = cld_incidence' call physics_message(mpas_err_message) config_radt_cld_scheme = "cld_incidence" @@ -255,18 +267,24 @@ subroutine physics_namelist_check(configs) endif !surface-layer scheme: - if(.not. (config_sfclayer_scheme .eq. 'off' .or. & - config_sfclayer_scheme .eq. 'sf_mynn' .or. & - config_sfclayer_scheme .eq. 'sf_monin_obukhov')) then + if(.not. (config_sfclayer_scheme .eq. 'off' .or. & + config_sfclayer_scheme .eq. 'sf_mynn' .or. & + config_sfclayer_scheme .eq. 'sf_monin_obukhov' .or. & + config_sfclayer_scheme .eq. 'sf_monin_obukhov_rev')) then - write(mpas_err_message,'(A,A10)') 'illegal value for surface layer scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for surface layer scheme: ', & trim(config_sfclayer_scheme) call physics_error_fatal(mpas_err_message) else if(config_pbl_scheme == 'bl_mynn') then config_sfclayer_scheme = 'sf_mynn' elseif(config_pbl_scheme == 'bl_ysu') then - config_sfclayer_scheme = 'sf_monin_obukhov' + if(config_sfclayer_scheme /= 'sf_monin_obukhov' .and. & + config_sfclayer_scheme /= 'sf_monin_obukhov_rev') then + write(mpas_err_message,'(A,A20)') 'wrong choice for surface layer scheme with YSU PBL: ', & + trim(config_sfclayer_scheme) + call physics_error_fatal(mpas_err_message) + endif endif endif @@ -277,10 +295,11 @@ subroutine physics_namelist_check(configs) call physics_error_fatal('land surface scheme: ' // & 'set config_sfclayer_scheme different than off') - elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & - config_lsm_scheme .eq. 'noah')) then + elseif(.not. (config_lsm_scheme .eq. 'off ' .or. & + config_lsm_scheme .eq. 'sf_noah' .or. & + config_lsm_scheme .eq. 'sf_noahmp')) then - write(mpas_err_message,'(A,A10)') 'illegal value for land surface scheme: ', & + write(mpas_err_message,'(A,A20)') 'illegal value for land surface scheme: ', & trim(config_lsm_scheme) call physics_error_fatal(mpas_err_message) @@ -349,7 +368,7 @@ subroutine physics_registry_init(mesh,configs,sfc_input) lsm_select: select case(trim(config_lsm_scheme)) - case("noah") + case("sf_noah","sf_noahmp") !initialize the thickness of the soil layers for the Noah scheme: do iCell = 1, nCells dzs(1,iCell) = 0.10_RKIND @@ -388,7 +407,8 @@ subroutine physics_tables_init(dminfo,configs) if(dminfo % my_proc_id == IO_NODE) then call mpas_pool_get_config(configs,'config_microp_scheme',config_microp_scheme) - if(config_microp_scheme /= "mp_thompson") return + if(config_microp_scheme /= "mp_thompson" .or. & + config_microp_scheme /= "mp_thompson_aerosols") return l_qr_acr_qg = .false. l_qr_acr_qs = .false. @@ -448,6 +468,9 @@ subroutine physics_compatibility_check(dminfo, blockList, streamManager, ierr) real (kind=RKIND) :: maxvar2d_local, maxvar2d_global real (kind=RKIND), dimension(:), pointer :: var2d integer, pointer :: nCellsSolve + integer, pointer :: iswater_lu + integer, pointer, dimension(:) :: ivgtyp + integer :: all_water, iall_water character (len=StrKIND), pointer :: gwdo_scheme type (block_type), pointer :: block type (mpas_pool_type), pointer :: meshPool @@ -473,7 +496,22 @@ subroutine physics_compatibility_check(dminfo, blockList, streamManager, ierr) call mpas_dmpar_max_real(dminfo, maxvar2d_local, maxvar2d_global) - if (maxvar2d_global <= 0.0_RKIND) then + ! + ! The GWDO check below can fail on regional simulations that are completely above + ! water. So, check to see if the simulation is completely above water and do not + ! throw the error if it is. + ! + call mpas_pool_get_array(sfc_inputPool, 'iswater', iswater_lu) + call mpas_pool_get_array(sfc_inputPool, 'ivgtyp', ivgtyp) + if (all(ivgtyp(1:nCellsSolve) == iswater_lu)) then + all_water = 1 ! All water + else + all_water = 0 ! Land present + end if + + call mpas_dmpar_min_int(dminfo, all_water, iall_water) + + if (maxvar2d_global <= 0.0_RKIND .and. iall_water /= 1) then call mpas_log_write('*******************************************************************************', & messageType=MPAS_LOG_ERR) call mpas_log_write('The GWDO scheme requires valid var2d, con, oa{1,2,3,4}, and ol{1,2,3,4} fields,', & diff --git a/src/core_atmosphere/physics/mpas_atmphys_date_time.F b/src/core_atmosphere/physics/mpas_atmphys_date_time.F index 356198e05c..65b5349073 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_date_time.F +++ b/src/core_atmosphere/physics/mpas_atmphys_date_time.F @@ -13,6 +13,7 @@ module mpas_atmphys_date_time implicit none private public:: get_julgmt, & + cal_mon_day, & monthly_interp_to_date, & monthly_min_max @@ -37,6 +38,10 @@ module mpas_atmphys_date_time ! * in subroutines get_julgmt_date and split_date_char, changed the declaration of date_str ! from StrKIND to *. ! Laura D. Fowler (laura@ucar.edu) / 2013-10-18. +! * added the subroutine cal_mon_day. This subroutine was copied from module_ra_gfdleta.F from WRF version 3.9.0. +! It is used in the updated module module_sf_noahdrv.F, but only if we run the urban physics option which we do +! not. So this subroutine is currently not used. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-10. contains @@ -78,6 +83,45 @@ subroutine get_julgmt(date_str,julyr,julday,gmt) end subroutine get_julgmt +!================================================================================================================= + subroutine cal_mon_day(julday,julyr,jmonth,jday) +!================================================================================================================= + +!input arguments: + integer,intent(in):: julday,julyr + +!output arguments: + integer,intent(out):: jmonth,jday + +!local variables: + logical:: leap,not_find_date + integer:: month (12),itmpday,itmpmon,i + data month/31,28,31,30,31,30,31,31,30,31,30,31/ + + not_find_date = .true. + + itmpday = julday + itmpmon = 1 + leap=.false. + if(mod(julyr,4).eq.0)then + month(2)=29 + leap=.true. + endif + + i = 1 + do while (not_find_date) + if(itmpday.gt.month(i))then + itmpday=itmpday-month(i) + else + jday=itmpday + jmonth=i + not_find_date = .false. + endif + i = i+1 + enddo + + end subroutine cal_mon_day + !================================================================================================================= subroutine split_date_char(date,century_year,month,day,hour,minute,second,ten_thousandth) !================================================================================================================= @@ -171,6 +215,7 @@ subroutine monthly_interp_to_date(npoints,date_str,field_in,field_out) endif enddo find_month + end subroutine monthly_interp_to_date !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver.F b/src/core_atmosphere/physics/mpas_atmphys_driver.F index b120d0ccc4..402517e98f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver.F @@ -14,9 +14,11 @@ module mpas_atmphys_driver use mpas_atmphys_driver_convection use mpas_atmphys_driver_gwdo use mpas_atmphys_driver_lsm + use mpas_atmphys_driver_lsm_noahmp 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 @@ -97,6 +99,8 @@ module mpas_atmphys_driver ! * modified call to driver_cloudiness to accomodate the calculation of the cloud fraction with the Thompson ! cloud microphysics scheme. ! Laura D. Fowler (laura@ucar.edu) / 2016-06-04. +! * added call to the Noah-MP land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. contains @@ -114,13 +118,15 @@ subroutine physics_driver(domain,itimestep,xtime_s) type(domain_type),intent(inout):: domain !local pointers: - type(mpas_pool_type),pointer:: configs, & - mesh, & - state, & - diag, & - diag_physics, & - tend_physics, & - atm_input, & + type(mpas_pool_type),pointer:: configs, & + mesh, & + state, & + diag, & + diag_physics, & + diag_physics_noahmp, & + output_noahmp, & + tend_physics, & + atm_input, & sfc_input logical,pointer:: config_frac_seaice @@ -174,18 +180,20 @@ subroutine physics_driver(domain,itimestep,xtime_s) block => domain % blocklist do while(associated(block)) - call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) - call mpas_pool_get_subpool(block%structs,'state' ,state ) - call mpas_pool_get_subpool(block%structs,'diag' ,diag ) - call mpas_pool_get_subpool(block%structs,'diag_physics',diag_physics) - call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) - call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) - call mpas_pool_get_subpool(block%structs,'tend_physics',tend_physics) + call mpas_pool_get_subpool(block%structs,'mesh' ,mesh ) + call mpas_pool_get_subpool(block%structs,'state' ,state ) + call mpas_pool_get_subpool(block%structs,'diag' ,diag ) + call mpas_pool_get_subpool(block%structs,'diag_physics' ,diag_physics ) + call mpas_pool_get_subpool(block%structs,'diag_physics_noahmp',diag_physics_noahmp) + call mpas_pool_get_subpool(block%structs,'output_noahmp' ,output_noahmp ) + call mpas_pool_get_subpool(block%structs,'atm_input' ,atm_input ) + call mpas_pool_get_subpool(block%structs,'sfc_input' ,sfc_input ) + call mpas_pool_get_subpool(block%structs,'tend_physics' ,tend_physics ) - call mpas_pool_get_dimension(block % dimensions, 'nThreads', nThreads) + call mpas_pool_get_dimension(block%dimensions,'nThreads',nThreads) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadStart', cellSolveThreadStart) - call mpas_pool_get_dimension(block % dimensions, 'cellSolveThreadEnd', cellSolveThreadEnd) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadStart',cellSolveThreadStart) + call mpas_pool_get_dimension(block%dimensions,'cellSolveThreadEnd',cellSolveThreadEnd) !allocate arrays shared by all physics parameterizations: call allocate_forall_physics(block%configs) @@ -196,7 +204,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call MPAS_to_physics(block%configs,mesh,state,time_lev,diag,diag_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO @@ -219,7 +227,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) do thread=1,nThreads call driver_radiation_sw(itimestep,block%configs,mesh,state,time_lev,diag_physics, & atm_input,sfc_input,tend_physics,xtime_s, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO endif @@ -232,7 +240,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) do thread=1,nThreads call driver_radiation_lw(xtime_s,block%configs,mesh,state,time_lev,diag_physics, & atm_input,sfc_input,tend_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO endif @@ -242,7 +250,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call update_radiation_diagnostics(block%configs,mesh,diag_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO endif @@ -259,25 +267,43 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_sfclayer(itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_sfclayer(block%configs) endif !call to 1d ocean mixed-layer model - if(config_oml1d) call driver_oml1d(block%configs, mesh, diag, diag_physics, sfc_input) + if(config_oml1d) call driver_oml1d(block%configs,mesh,diag,diag_physics,sfc_input) !call to land-surface scheme: if(config_lsm_scheme .ne. 'off') then - call allocate_lsm(config_frac_seaice) + if(config_lsm_scheme == 'sf_noah') then + 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 + + elseif(config_lsm_scheme == 'sf_noahmp') then + do thread=1,nThreads + call driver_lsm_noahmp(block%configs,mesh,state,time_lev,diag,diag_physics, & + diag_physics_noahmp,output_noahmp,sfc_input,itimestep, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo + endif + + call allocate_seaice !$OMP PARALLEL DO do thread=1,nThreads - call driver_lsm(itimestep,block%configs,mesh,diag_physics,sfc_input, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) - end do + call driver_seaice(block%configs,diag_physics,sfc_input, & + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) + enddo !$OMP END PARALLEL DO - call deallocate_lsm(config_frac_seaice) + call deallocate_seaice endif !call to pbl schemes: @@ -317,7 +343,7 @@ subroutine physics_driver(domain,itimestep,xtime_s) !$OMP PARALLEL DO do thread=1,nThreads call driver_convection(itimestep,block%configs,mesh,sfc_input,diag_physics,tend_physics, & - cellSolveThreadStart(thread), cellSolveThreadEnd(thread)) + cellSolveThreadStart(thread),cellSolveThreadEnd(thread)) end do !$OMP END PARALLEL DO call deallocate_convection(block%configs) diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F index 9e444ae2f7..93e833b328 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_cloudiness.F @@ -51,7 +51,10 @@ module mpas_atmphys_driver_cloudiness ! Laura D. Fowler (laura@ucar.edu) / 2016-07-05. ! * since we removed the local variable radt_cld_scheme from mpas_atmphys_vars.F, now defines radt_cld_scheme ! as a pointer to config_radt_cld_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * this is a bug fix. dx_p is converted from meters to kilometers prior to calling the thompson parameterization +! of the cloud fraction. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-23. contains @@ -119,6 +122,8 @@ subroutine cloudiness_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) do j = jts,jte do i = its,ite dx_p(i,j) = len_disp / meshDensity(i)**0.25 + !conversion of dx_p from meters to kilometers. + dx_p(i,j) = dx_p(i,j)*0.001 xland_p(i,j) = xland(i) enddo diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F index 58f9bfaefc..763776bf7f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_convection.F @@ -19,7 +19,7 @@ module mpas_atmphys_driver_convection use module_cu_gf use module_cu_kfeta use module_cu_tiedtke - use module_cu_ntiedtke + use module_cu_ntiedtke,only: cu_ntiedtke_driver implicit none private @@ -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 @@ -435,10 +438,18 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ real(kind=RKIND):: cudt real(kind=RKIND):: cudtacttime +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_convection:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_gfconv_closure_deep',gfconv_closure_deep) call mpas_pool_get_config(configs,'config_gfconv_closure_shallow',gfconv_closure_shallow) call mpas_pool_get_config(configs,'config_len_disp' ,len_disp ) @@ -510,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 , & @@ -530,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 , & @@ -545,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 & @@ -569,31 +578,34 @@ subroutine driver_convection(itimestep,configs,mesh,sfc_input,diag_physics,tend_ call mpas_timer_stop('Tiedtke') case("cu_ntiedtke") - call mpas_timer_start('New_Tiedtke') - call cu_ntiedtke( & - 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 , & + 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_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 & ) - call mpas_timer_stop('New_Tiedtke') + call mpas_timer_stop('cu_ntiedtke') case default diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F index 08eee06635..06bf5ef0ea 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_gwdo.F @@ -9,7 +9,7 @@ module mpas_atmphys_driver_gwdo 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 @@ -57,6 +57,11 @@ module mpas_atmphys_driver_gwdo ! Laura D. Fowler (laura@ucar.edu) / 2016-03-25. ! * change the definition of dx_p to match that used in other physics parameterizations. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. +! * modified the call to subroutine gwdo following the update of module_gwdo.F to that +! of WRF version 4.0.2. +! Laura D. Fowler (laura@ucar.edu) / 2019-01-30. +! * added the flags errmsg and errflg in the call to subroutine gwdo for compliance with the CCPP framework. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. contains @@ -66,6 +71,9 @@ module mpas_atmphys_driver_gwdo subroutine allocate_gwdo !================================================================================================================= + if(.not.allocated(cosa_p) ) allocate(cosa_p(ims:ime,jms:jme) ) + if(.not.allocated(sina_p) ) allocate(sina_p(ims:ime,jms:jme) ) + if(.not.allocated(dx_p) ) allocate(dx_p(ims:ime,jms:jme) ) if(.not.allocated(var2d_p) ) allocate(var2d_p(ims:ime,jms:jme) ) if(.not.allocated(con_p) ) allocate(con_p(ims:ime,jms:jme) ) @@ -92,6 +100,9 @@ end subroutine allocate_gwdo subroutine deallocate_gwdo !================================================================================================================= + if(allocated(cosa_p) ) deallocate(cosa_p ) + if(allocated(sina_p) ) deallocate(sina_p ) + if(allocated(dx_p) ) deallocate(dx_p ) if(allocated(var2d_p) ) deallocate(var2d_p ) if(allocated(con_p) ) deallocate(con_p ) @@ -164,6 +175,10 @@ subroutine gwdo_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,i do j = jts,jte do i = its,ite + + sina_p(i,j) = 0._RKIND + cosa_p(i,j) = 1._RKIND + var2d_p(i,j) = var2d(i) con_p(i,j) = con(i) oa1_p(i,j) = oa1(i) @@ -272,10 +287,18 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic integer:: i,iCell,iEdge real(kind=RKIND),dimension(:),allocatable:: dx_max +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_gwdo:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_gwdo_scheme',gwdo_scheme) !copy MPAS arrays to local arrays: @@ -284,11 +307,11 @@ 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('GWDO_YSU') + 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 , & - qv3d = qv_p , z = z_p , rublten = rublten_p , & + qv3d = qv_p , z = zmid_p , rublten = rublten_p , & rvblten = rvblten_p , dtaux3d = dtaux3d_p , dtauy3d = dtauy3d_p , & dusfcg = dusfcg_p , dvsfcg = dvsfcg_p , kpbl2d = kpbl_p , & itimestep = itimestep , dt = dt_pbl , dx = dx_p , & @@ -297,12 +320,13 @@ subroutine driver_gwdo(itimestep,configs,mesh,sfc_input,diag_physics,tend_physic var2d = var2d_p , oc12d = con_p , oa2d1 = oa1_p , & oa2d2 = oa2_p , oa2d3 = oa3_p , oa2d4 = oa4_p , & ol2d1 = ol1_p , ol2d2 = ol2_p , ol2d3 = ol3_p , & - ol2d4 = ol4_p , & + ol2d4 = ol4_p , sina = sina_p , cosa = cosa_p , & + 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 & ) - call mpas_timer_stop('GWDO_YSU') + 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 c2c902d3e4..0116dcf561 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm.F @@ -12,12 +12,13 @@ module mpas_atmphys_driver_lsm use mpas_timer, only : mpas_timer_start, mpas_timer_stop use mpas_atmphys_constants - use mpas_atmphys_landuse + use mpas_atmphys_landuse, only: isurban use mpas_atmphys_lsm_noahinit use mpas_atmphys_vars !wrf physics use module_sf_noahdrv + use module_sf_noah_seaice_drv use module_sf_sfcdiags implicit none @@ -82,9 +83,26 @@ module mpas_atmphys_driver_lsm ! Laura D. Fowler (laura@ucar.edu) / 2016-05-11. ! * added the calculation of surface variables over seaice cells when config_frac_seaice is set to true. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-03. +! * now use isice and iswater initialized in the init file instead of initialized in mpas_atmphys_landuse.F. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-13. +! * updated the call to subroutine lsm as we updated the Noah LSM scheme to WRF version 3.9.0. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-30. ! * since we removed the local variable lsm_scheme from mpas_atmphys_vars.F, now defines lsm_scheme as a ! pointer to config_lsm_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * added call to seaice_noah to include the parameterization of seaice for the updated Noah land surface +! scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-19. +! * the initialization of the variable albsi_p is switched from sfc_albedo_seaice (which is originally +! initialized to albbck to seaice_albedo_default. Note that albsi_p is not used if seaice_albedo_opt = 0. +! 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. ! @@ -101,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)) @@ -155,6 +170,8 @@ subroutine allocate_lsm(config_frac_seaice) 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(sr_p) ) allocate(sr_p(ims:ime,jms:jme) ) + if(.not.allocated(swddir_p) ) allocate(swddir_p(ims:ime,jms:jme) ) + if(.not.allocated(swddif_p) ) allocate(swddif_p(ims:ime,jms:jme) ) if(.not.allocated(swdown_p) ) allocate(swdown_p(ims:ime,jms:jme) ) if(.not.allocated(tmn_p) ) allocate(tmn_p(ims:ime,jms:jme) ) if(.not.allocated(tsk_p) ) allocate(tsk_p(ims:ime,jms:jme) ) @@ -164,24 +181,20 @@ 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(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)) - endif + 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) ) + if(.not.allocated(fgsnsnow_p) ) allocate(fgsnsnow_p(ims:ime,jms:jme) ) + if(.not.allocated(frc_urb_p) ) allocate(frc_urb_p(ims:ime,jms:jme) ) + 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) ) 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) @@ -230,6 +243,8 @@ subroutine deallocate_lsm(config_frac_seaice) if(allocated(snowc_p) ) deallocate(snowc_p ) if(allocated(snowh_p) ) deallocate(snowh_p ) if(allocated(sr_p) ) deallocate(sr_p ) + if(allocated(swddir_p) ) deallocate(swddir_p ) + if(allocated(swddif_p) ) deallocate(swddif_p ) if(allocated(swdown_p) ) deallocate(swdown_p ) if(allocated(tmn_p) ) deallocate(tmn_p ) if(allocated(tsk_p) ) deallocate(tsk_p ) @@ -239,23 +254,13 @@ 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(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 ) - endif + if(allocated(flxsnow_p) ) deallocate(flxsnow_p ) + if(allocated(fvbsnow_p) ) deallocate(fvbsnow_p ) + if(allocated(fbursnow_p) ) deallocate(fbursnow_p ) + if(allocated(fgsnsnow_p) ) deallocate(fgsnsnow_p ) + if(allocated(frc_urb_p) ) deallocate(frc_urb_p ) + if(allocated(ust_urb_p) ) deallocate(ust_urb_p ) + if(allocated(utype_urb_p) ) deallocate(utype_urb_p ) end subroutine deallocate_lsm @@ -271,20 +276,18 @@ 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 integer,dimension(:),pointer:: isltyp,ivgtyp - real(kind=RKIND),dimension(:),pointer :: acsnom,acsnow,canwat,chs,chs2,chklowq,cpm,cqs2,glw, & - grdflx,gsw,hfx,lai,lh,noahres,potevp,qfx,qgh,qsfc, & - br,sfc_albedo,sfc_emibck,sfc_emiss,sfcrunoff, & - smstav,smstot,snotime,snopcx,sr,udrunoff,z0,znt + real(kind=RKIND),dimension(:),pointer :: acsnom,acsnow,canwat,chs,chs2,chklowq,cpm,cqs2,glw, & + grdflx,gsw,hfx,lai,lh,noahres,potevp,qfx,qgh,qsfc, & + br,sfc_albedo,sfc_emibck,sfc_emiss,sfcrunoff,smstav, & + smstot,snotime,snopcx,sr,swddif,swddir,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,dzs @@ -295,7 +298,6 @@ 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 ) @@ -327,32 +329,31 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) 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(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,'dzs' ,dzs ) - 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,'dzs' ,dzs ) + 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 ) !In Registry.xml, dzs is a function of nCells. In the Noah lsm scheme, dzs is independent !of cell locations: @@ -401,12 +402,11 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) smstot_p(i,j) = smstot(i) snotime_p(i,j) = snotime(i) snopcx_p(i,j) = snopcx(i) + swddif_p(i,j) = swddif(i) + swddir_p(i,j) = swddir(i) 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) @@ -423,34 +423,21 @@ subroutine lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) xice_p(i,j) = xice(i) xland_p(i,j) = xland(i) - qz0_p(i,j) = 0._RKIND - enddo - enddo + qz0_p(i,j) = 0._RKIND -!modify the surface albedo and surface emissivity, and surface temperatures over sea-ice points: - if(config_frac_seaice) then - do j = jts,jte - do i = its,ite - 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 + !initialization of arrays to run the UA Noah LSM snow cover parameterization: + flxsnow_p(i,j) = 0._RKIND + fvbsnow_p(i,j) = 0._RKIND + fbursnow_p(i,j) = 0._RKIND + fgsnsnow_p(i,j) = 0._RKIND - !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) + !initialization of arrays to run the Noah LSM urban parameterization (not currently + frc_urb_p(i,j) = 0._RKIND + ust_urb_p(i,j) = 0._RKIND + utype_urb_p(i,j) = 0 - do j = jts,jte - do i = its,ite - tsk_p(i,j) = tsk_ice(i,j) - enddo - enddo - endif + enddo + enddo do j = jts,jte do i = its,ite @@ -501,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 @@ -513,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 @@ -523,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 ) @@ -559,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 @@ -626,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) @@ -643,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) @@ -698,7 +654,7 @@ subroutine init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) lsm_select: select case (trim(lsm_scheme)) - case ("noah") + case ("sf_noah") call noah_init_forMPAS(dminfo,mesh,configs,diag_physics,sfc_input) case default @@ -726,71 +682,72 @@ subroutine driver_lsm(itimestep,configs,mesh,diag_physics,sfc_input,its,ite) logical,pointer:: config_sfc_albedo character(len=StrKIND),pointer:: lsm_scheme character(len=StrKIND),pointer:: mminlu + integer,pointer:: isice !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !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_sfc_albedo' ,config_sfc_albedo ) 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 ) !copy MPAS arrays to local arrays: call lsm_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) +!write(0,*) '--- end lsm_from_MPAS' !call to land-surface scheme: lsm_select: select case (trim(lsm_scheme)) - case("noah") - call mpas_timer_start('Noah') + case("sf_noah") + call mpas_timer_start('sf_noah') call lsm( & - dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & - qv3d = qv_p , xland = xland_p , xice = xice_p , & - ivgtyp = ivgtyp_p , isltyp = isltyp_p , tmn = tmn_p , & - vegfra = vegfra_p , shdmin = shdmin_p , shdmax = shdmax_p , & - snoalb = snoalb_p , glw = glw_p , gsw = gsw_p , & - swdown = swdown_p , rainbl = rainbl_p , embck = sfc_emibck_p , & - sr = sr_p , qgh = qgh_p , cpm = cpm_p , & - qz0 = qz0_p , tsk = tsk_p , hfx = hfx_p , & - qfx = qfx_p , lh = lh_p , grdflx = grdflx_p , & - qsfc = qsfc_p , cqs2 = cqs2_p , chs = chs_p , & - chs2 = chs2_p , snow = snow_p , snowc = snowc_p , & - snowh = snowh_p , canwat = canwat_p , smstav = smstav_p , & - smstot = smstot_p , sfcrunoff = sfcrunoff_p , udrunoff = udrunoff_p , & - acsnom = acsnom_p , acsnow = acsnow_p , snotime = snotime_p , & - snopcx = snopcx_p , emiss = sfc_emiss_p , rib = br_p , & - potevp = potevp_p , albedo = sfc_albedo_p , albbck = sfc_albbck_p , & - z0 = z0_p , znt = znt_p , lai = lai_p , & - noahres = noahres_p , chklowq = chklowq_p , sh2o = sh2o_p , & - smois = smois_p , tslb = tslb_p , smcrel = smcrel_p , & - dzs = dzs_p , isurban = isurban , isice = isice , & - rovcp = rcp , dt = dt_pbl , myj = myj , & - itimestep = itimestep , frpcpn = frpcpn , rdlai2d = rdlai2d , & - xice_threshold = xice_threshold , & - usemonalb = config_sfc_albedo , & - mminlu = mminlu , & - num_soil_layers = num_soils , & - num_roof_layers = num_soils , & - num_wall_layers = num_soils , & - num_road_layers = num_soils , & - num_urban_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 & + dz8w = dz_p , p8w3d = pres2_hyd_p , t3d = t_p , & + qv3d = qv_p , xland = xland_p , xice = xice_p , & + ivgtyp = ivgtyp_p , isltyp = isltyp_p , tmn = tmn_p , & + vegfra = vegfra_p , shdmin = shdmin_p , shdmax = shdmax_p , & + snoalb = snoalb_p , glw = glw_p , gsw = gsw_p , & + swdown = swdown_p , rainbl = rainbl_p , embck = sfc_emibck_p , & + sr = sr_p , qgh = qgh_p , cpm = cpm_p , & + qz0 = qz0_p , tsk = tsk_p , hfx = hfx_p , & + qfx = qfx_p , lh = lh_p , grdflx = grdflx_p , & + qsfc = qsfc_p , cqs2 = cqs2_p , chs = chs_p , & + chs2 = chs2_p , snow = snow_p , snowc = snowc_p , & + snowh = snowh_p , canwat = canwat_p , smstav = smstav_p , & + smstot = smstot_p , sfcrunoff = sfcrunoff_p , udrunoff = udrunoff_p , & + acsnom = acsnom_p , acsnow = acsnow_p , snotime = snotime_p , & + snopcx = snopcx_p , emiss = sfc_emiss_p , rib = br_p , & + potevp = potevp_p , albedo = sfc_albedo_p , albbck = sfc_albbck_p , & + z0 = z0_p , znt = znt_p , lai = lai_p , & + noahres = noahres_p , chklowq = chklowq_p , sh2o = sh2o_p , & + smois = smois_p , tslb = tslb_p , smcrel = smcrel_p , & + dzs = dzs_p , isurban = isurban , isice = isice , & + rovcp = rcp , dt = dt_pbl , myj = myj , & + itimestep = itimestep , frpcpn = frpcpn , rdlai2d = rdlai2d , & + opt_thcnd = opt_thcnd , ua_phys = ua_phys , flx4_2d = flxsnow_p , & + fvb_2d = fvbsnow_p , fbur_2d = fbursnow_p , fgsn_2d = fgsnsnow_p , & + utype_urb2d = utype_urb_p , frc_urb2d = frc_urb_p , ust_urb2d = ust_urb_p , & + swddir = swddir_p , swddif = swddif_p , fasdas = fasdas , & + julian = 0 , julyr = 0 , & + num_soil_layers = num_soils , & + xice_threshold = xice_threshold , & + usemonalb = config_sfc_albedo , & + mminlu = mminlu , & + sf_urban_physics = sf_urban_physics , & + num_roof_layers = nurb , num_wall_layers = nurb , & + num_road_layers = nurb , num_urban_hi = nurb , & + num_urban_ndm = nurb , urban_map_zrd = nurb , & + urban_map_zwd = nurb , urban_map_gd = nurb , & + urban_map_zd = nurb , urban_map_zdf = nurb , & + urban_map_bd = nurb , urban_map_wd = nurb , & + urban_map_gbd = nurb , urban_map_fbd = nurb , & + urban_map_zgrd = nurb , & + 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 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('Noah') - + call mpas_timer_stop('sf_noah') case default @@ -803,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_lsm_noahmp.F b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F new file mode 100644 index 0000000000..8bbec89911 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_lsm_noahmp.F @@ -0,0 +1,1094 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and 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_lsm_noahmp + use mpas_kind_types + use mpas_log + use mpas_pool_routines + use mpas_timer,only: mpas_timer_start, mpas_timer_stop + + use mpas_atmphys_constants,only: R_d,R_v + use mpas_atmphys_manager,only : year,curr_julday,month,day + use mpas_atmphys_vars,only : mpas_noahmp,xice_threshold + + + use NoahmpIOVarType + use NoahmpDriverMainMod,only: NoahmpDriverMain + + implicit none + private + public:: driver_lsm_noahmp + + + contains + + +!================================================================================================================= + subroutine lsm_noahmp_fromMPAS(configs,mesh,diag,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input, & + state,time_lev,itimestep) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + + integer,intent(in):: time_lev + integer,intent(in):: itimestep + + +!--- inout arguments: + type(mpas_pool_type),intent(in):: diag_physics + type(mpas_pool_type),intent(in):: diag_physics_noahmp + type(mpas_pool_type),intent(in):: output_noahmp + type(mpas_pool_type),intent(in):: sfc_input + + +!--- local variables and arrays: + logical,pointer:: do_restart + + character(len=StrKIND),pointer:: microp_scheme, & + convection_scheme + + integer:: i,its,ite + integer:: n,ns,nsoil,nsnow,nzsnow + integer,dimension(:),pointer:: isltyp,ivgtyp + + real(kind=RKIND),dimension(:),pointer:: latCell,lonCell + real(kind=RKIND),dimension(:),pointer:: shdmax,shdmin,vegfra,tmn,xice,xland + + real(kind=RKIND),dimension(:),pointer:: coszr,glw,gsw,swddir,swddif + real(kind=RKIND),dimension(:),pointer:: graupelncv,raincv,rainncv,snowncv,sr + + +!--- local INOUT pointers (with generic LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: acsnom,acsnow,canwat,hfx,qfx,qsfc,lh,grdflx,sfc_albedo,sfc_emiss, & + sfcrunoff,skintemp,smstav,smstot,udrunoff,snow,snowc,snowh,lai,z0, & + znt + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smois,tslb + + +!--- local INOUT pointers (with no Noah LSM equivalent as defined in WRF): + integer,dimension(:),pointer:: isnowxy + real(kind=RKIND),dimension(:),pointer:: tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy, & + alboldxy,qsnowxy,qrainxy,wslakexy,zwtxy,waxy,wtxy,deeprechxy, & + rechxy,lfmassxy,rtmassxy,stmassxy,woodxy,grainxy,gddxy,stblcpxy, & + fastcpxy,xsaixy,taussxy + real(kind=RKIND),dimension(:,:),pointer:: tsnoxy,zsnsoxy,snicexy,snliqxy + + +!--- local OUT pointers (with no Noah LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,runsfxy, & + runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy, & + rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy, & + shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy, & + chucxy,chv2xy,chb2xy,rs,qtdrain + + +!--- local OUT additional variables: + real(kind=RKIND),dimension(:),pointer:: pahxy,pahgxy,pahbxy,pahvxy,qintsxy,qintrxy,qdripsxy,qdriprxy, & + qthrosxy,qthrorxy,qsnsubxy,qmeltxy,qsnfroxy,qsubcxy,qfrocxy, & + qevacxy,qdewcxy,qfrzcxy,qmeltcxy,qsnbotxy,pondingxy,fpicexy, & + rainlsm,snowlsm,forctlsm,forcqlsm,forcplsm,forczlsm,forcwlsm, & + acc_ssoilxy,acc_qinsurxy,acc_qsevaxy,eflxbxy,soilenergy,snowenergy, & + canhsxy,acc_dwaterxy,acc_prcpxy,acc_ecanxy,acc_etranxy,acc_edirxy + real(kind=RKIND),dimension(:,:),pointer:: acc_etranixy + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine lsm_noahmp_fromMPAS: itimestep = $i',intArgs=(/itimestep/)) + + call mpas_pool_get_config(configs,'config_do_restart',do_restart) + + call mpas_pool_get_config(configs,'config_convection_scheme',convection_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + nsoil = mpas_noahmp%nsoil + nsnow = mpas_noahmp%nsnow + nzsnow = nsnow + nsoil + + +!--- initialization of time-varying variables: + mpas_noahmp%restart_flag = do_restart + + mpas_noahmp%soiltstep = 0 + mpas_noahmp%itimestep = itimestep + mpas_noahmp%yr = year + mpas_noahmp%month = month + mpas_noahmp%day = day + mpas_noahmp%julian = curr_julday + + +!--- initialization of xice_threshold: + mpas_noahmp%xice_threshold = xice_threshold + + +!--- initialization of INPUT surface variables: + call mpas_pool_get_array(sfc_input,'shdmax',shdmax) + call mpas_pool_get_array(sfc_input,'shdmin',shdmin) + call mpas_pool_get_array(sfc_input,'vegfra',vegfra) + call mpas_pool_get_array(sfc_input,'tmn' ,tmn ) + call mpas_pool_get_array(sfc_input,'xice' ,xice ) + call mpas_pool_get_array(sfc_input,'xland' ,xland ) + + call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) + 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,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) + call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) + call mpas_pool_get_array(diag_physics,'sr' ,sr ) + call mpas_pool_get_array(diag_physics,'raincv' ,raincv ) + call mpas_pool_get_array(diag_physics,'rainncv' ,rainncv ) + call mpas_pool_get_array(diag_physics,'snowncv' ,snowncv ) + call mpas_pool_get_array(diag_physics,'graupelncv',graupelncv) + + do i = its,ite + mpas_noahmp%coszen(i) = coszr(i) + mpas_noahmp%gvfmax(i) = shdmax(i) + mpas_noahmp%gvfmin(i) = shdmin(i) + mpas_noahmp%vegfra(i) = vegfra(i) + mpas_noahmp%tmn(i) = tmn(i) + mpas_noahmp%xland(i) = xland(i) + mpas_noahmp%xice(i) = xice(i) + mpas_noahmp%swdown(i) = gsw(i) / (1.-sfc_albedo(i)) + mpas_noahmp%swddir(i) = swddir(i) + mpas_noahmp%swddif(i) = swddif(i) + mpas_noahmp%glw(i) = glw(i) + mpas_noahmp%rainbl(i) = 0. + mpas_noahmp%snowbl(i) = 0. + mpas_noahmp%rainshv(i) = 0. + mpas_noahmp%hailncv(i) = 0. + mpas_noahmp%mp_hail(i) = 0. + mpas_noahmp%mp_shcv(i) = 0. + mpas_noahmp%seaice(i) = 0. + enddo + +!--- calculation of the instantaneous precipitation rates of rain and snow: + if(microp_scheme .ne. 'off') then + do i = its,ite + mpas_noahmp%sr(i) = sr(i) + mpas_noahmp%rainncv(i) = rainncv(i) + mpas_noahmp%snowncv(i) = snowncv(i) + mpas_noahmp%graupelncv(i) = graupelncv(i) + mpas_noahmp%rainbl(i) = mpas_noahmp%rainbl(i) + mpas_noahmp%rainncv(i) + mpas_noahmp%snowbl(i) = mpas_noahmp%snowbl(i) + mpas_noahmp%snowncv(i) + + mpas_noahmp%mp_rainnc(i) = rainncv(i) + mpas_noahmp%mp_snow(i) = snowncv(i) + mpas_noahmp%mp_graup(i) = graupelncv(i) + enddo + else + do i = its,ite + mpas_noahmp%sr(i) = 0. + mpas_noahmp%rainncv(i) = 0. + mpas_noahmp%snowncv(i) = 0. + mpas_noahmp%graupelncv(i) = 0. + + mpas_noahmp%mp_rainnc(i) = 0. + mpas_noahmp%mp_snow(i) = 0. + mpas_noahmp%mp_graup(i) = 0. + enddo + endif + if(convection_scheme .ne. 'off') then + do i = its,ite + mpas_noahmp%raincv(i) = raincv(i) + mpas_noahmp%rainbl(i) = mpas_noahmp%rainbl(i) + mpas_noahmp%raincv(i) + mpas_noahmp%raincv(i) = raincv(i) + + mpas_noahmp%mp_rainc(i) = raincv(i) + enddo + else + do i = its,ite + mpas_noahmp%raincv(i) = 0. + mpas_noahmp%mp_rainc(i) = 0. + enddo + endif + +!--- calculation of the incidence of fractional seaice: + do i = its,ite + mpas_noahmp%seaice(i) = 0. + if(mpas_noahmp%xice(i) .ge. xice_threshold) mpas_noahmp%seaice(i) = 1. + enddo + + +!--- initialization of INPUT sounding variables: + call lsm_noahmp_sounding_fromMPAS(mesh,state,time_lev,diag) + + +!--- initialization of INOUT variables (with generic LSM equivalent as defined in WRF), i.e. +! see lines 162-184 in module NoahmpIOVarType.F90): + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + 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,'grdflx' ,grdflx ) + 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,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + 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,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + + do i = its,ite + mpas_noahmp%tsk(i) = skintemp(i) + mpas_noahmp%hfx(i) = hfx(i) + mpas_noahmp%qfx(i) = qfx(i) + mpas_noahmp%lh(i) = lh(i) + mpas_noahmp%grdflx(i) = grdflx(i) + mpas_noahmp%smstav(i) = smstav(i) + mpas_noahmp%smstot(i) = smstot(i) + mpas_noahmp%sfcrunoff(i) = sfcrunoff(i) + mpas_noahmp%udrunoff(i) = udrunoff(i) + mpas_noahmp%albedo(i) = sfc_albedo(i) + mpas_noahmp%snowc(i) = snowc(i) + mpas_noahmp%snow(i) = snow(i) + mpas_noahmp%snowh(i) = snowh(i) + mpas_noahmp%canwat(i) = canwat(i) + mpas_noahmp%acsnom(i) = acsnom(i) + mpas_noahmp%acsnow(i) = acsnow(i) + mpas_noahmp%emiss(i) = sfc_emiss(i) + mpas_noahmp%qsfc(i) = qsfc(i) + mpas_noahmp%lai(i) = lai(i) + mpas_noahmp%z0(i) = z0(i) + mpas_noahmp%znt(i) = znt(i) + enddo + + do ns = 1,nsoil + do i = its,ite + mpas_noahmp%sh2o(i,ns) = sh2o(ns,i) + mpas_noahmp%smois(i,ns) = smois(ns,i) + mpas_noahmp%tslb(i,ns) = tslb(ns,i) + enddo + enddo + + +!--- initialization of INOUT variables (with no Noah LSM equivalent as defined in WRF), i.e. +! see lines 186-222 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(diag_physics_noahmp,'isnowxy' ,isnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tvxy' ,tvxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tgxy' ,tgxy ) + call mpas_pool_get_array(diag_physics_noahmp,'canicexy' ,canicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'canliqxy' ,canliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'eahxy' ,eahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tahxy' ,tahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'cmxy' ,cmxy ) + call mpas_pool_get_array(diag_physics_noahmp,'chxy' ,chxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fwetxy' ,fwetxy ) + call mpas_pool_get_array(diag_physics_noahmp,'sneqvoxy' ,sneqvoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'alboldxy' ,alboldxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qsnowxy' ,qsnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qrainxy' ,qrainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wslakexy' ,wslakexy ) + call mpas_pool_get_array(diag_physics_noahmp,'zwtxy' ,zwtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'waxy' ,waxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wtxy' ,wtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'deeprechxy',deeprechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rechxy' ,rechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tsnoxy' ,tsnoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'zsnsoxy' ,zsnsoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'snicexy' ,snicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'snliqxy' ,snliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'lfmassxy' ,lfmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rtmassxy' ,rtmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stmassxy' ,stmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'woodxy' ,woodxy ) + call mpas_pool_get_array(diag_physics_noahmp,'grainxy' ,grainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'gddxy' ,gddxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stblcpxy' ,stblcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fastcpxy' ,fastcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'xsaixy' ,xsaixy ) + call mpas_pool_get_array(diag_physics_noahmp,'taussxy' ,taussxy ) + + do i = its,ite + mpas_noahmp%isnowxy(i) = isnowxy(i) + mpas_noahmp%tvxy(i) = tvxy(i) + mpas_noahmp%tgxy(i) = tgxy(i) + mpas_noahmp%canicexy(i) = canicexy(i) + mpas_noahmp%canliqxy(i) = canliqxy(i) + mpas_noahmp%eahxy(i) = eahxy(i) + mpas_noahmp%tahxy(i) = tahxy(i) + mpas_noahmp%cmxy(i) = cmxy(i) + mpas_noahmp%chxy(i) = chxy(i) + mpas_noahmp%fwetxy(i) = fwetxy(i) + mpas_noahmp%sneqvoxy(i) = sneqvoxy(i) + mpas_noahmp%alboldxy(i) = alboldxy(i) + mpas_noahmp%qsnowxy(i) = qsnowxy(i) + mpas_noahmp%qrainxy(i) = qrainxy(i) + mpas_noahmp%wslakexy(i) = wslakexy(i) + mpas_noahmp%zwtxy(i) = zwtxy(i) + mpas_noahmp%waxy(i) = waxy(i) + mpas_noahmp%wtxy(i) = wtxy(i) + mpas_noahmp%deeprechxy(i) = deeprechxy(i) + mpas_noahmp%rechxy(i) = rechxy(i) + mpas_noahmp%lfmassxy(i) = lfmassxy(i) + mpas_noahmp%rtmassxy(i) = rtmassxy(i) + mpas_noahmp%stmassxy(i) = stmassxy(i) + mpas_noahmp%woodxy(i) = woodxy(i) + mpas_noahmp%grainxy(i) = grainxy(i) + mpas_noahmp%gddxy(i) = gddxy(i) + mpas_noahmp%stblcpxy(i) = stblcpxy(i) + mpas_noahmp%fastcpxy(i) = fastcpxy(i) + mpas_noahmp%xsaixy(i) = xsaixy(i) + mpas_noahmp%taussxy(i) = taussxy(i) + enddo + + do ns = 1,nsnow + n = ns - nsnow + do i = its,ite + mpas_noahmp%tsnoxy(i,n) = tsnoxy(ns,i) + mpas_noahmp%snicexy(i,n) = snicexy(ns,i) + mpas_noahmp%snliqxy(i,n) = snliqxy(ns,i) + mpas_noahmp%zsnsoxy(i,n) = zsnsoxy(ns,i) + enddo + enddo + do ns = nsnow+1,nzsnow + n = ns - nsnow + do i = its,ite + mpas_noahmp%zsnsoxy(i,n) = zsnsoxy(ns,i) + enddo + enddo + + +!--- initialization of OUT (with no Noah LSM equivalent as defined in WRF), i.e. +! see lines 242-290 in module NoahmpIOVarType.F90): + call mpas_pool_get_array(output_noahmp,'t2mvxy' ,t2mvxy ) + call mpas_pool_get_array(output_noahmp,'t2mbxy' ,t2mbxy ) + call mpas_pool_get_array(output_noahmp,'q2mvxy' ,q2mvxy ) + call mpas_pool_get_array(output_noahmp,'q2mbxy' ,q2mbxy ) + call mpas_pool_get_array(output_noahmp,'tradxy' ,tradxy ) + call mpas_pool_get_array(output_noahmp,'neexy' ,neexy ) + call mpas_pool_get_array(output_noahmp,'gppxy' ,gppxy ) + call mpas_pool_get_array(output_noahmp,'nppxy' ,nppxy ) + call mpas_pool_get_array(output_noahmp,'fvegxy' ,fvegxy ) + call mpas_pool_get_array(output_noahmp,'runsfxy' ,runsfxy ) + call mpas_pool_get_array(output_noahmp,'runsbxy' ,runsbxy ) + call mpas_pool_get_array(output_noahmp,'ecanxy' ,ecanxy ) + call mpas_pool_get_array(output_noahmp,'edirxy' ,edirxy ) + call mpas_pool_get_array(output_noahmp,'etranxy' ,etranxy ) + call mpas_pool_get_array(output_noahmp,'fsaxy' ,fsaxy ) + call mpas_pool_get_array(output_noahmp,'firaxy' ,firaxy ) + call mpas_pool_get_array(output_noahmp,'aparxy' ,aparxy ) + call mpas_pool_get_array(output_noahmp,'psnxy' ,psnxy ) + call mpas_pool_get_array(output_noahmp,'savxy' ,savxy ) + call mpas_pool_get_array(output_noahmp,'sagxy' ,sagxy ) + call mpas_pool_get_array(output_noahmp,'rssunxy' ,rssunxy ) + call mpas_pool_get_array(output_noahmp,'rsshaxy' ,rsshaxy ) + call mpas_pool_get_array(output_noahmp,'bgapxy' ,bgapxy ) + call mpas_pool_get_array(output_noahmp,'wgapxy' ,wgapxy ) + call mpas_pool_get_array(output_noahmp,'tgvxy' ,tgvxy ) + call mpas_pool_get_array(output_noahmp,'tgbxy' ,tgbxy ) + call mpas_pool_get_array(output_noahmp,'chvxy' ,chvxy ) + call mpas_pool_get_array(output_noahmp,'chbxy' ,chbxy ) + call mpas_pool_get_array(output_noahmp,'shgxy' ,shgxy ) + call mpas_pool_get_array(output_noahmp,'shcxy' ,shcxy ) + call mpas_pool_get_array(output_noahmp,'shbxy' ,shbxy ) + call mpas_pool_get_array(output_noahmp,'evgxy' ,evgxy ) + call mpas_pool_get_array(output_noahmp,'evbxy' ,evbxy ) + call mpas_pool_get_array(output_noahmp,'ghvxy' ,ghvxy ) + call mpas_pool_get_array(output_noahmp,'ghbxy' ,ghbxy ) + call mpas_pool_get_array(output_noahmp,'irgxy' ,irgxy ) + call mpas_pool_get_array(output_noahmp,'ircxy' ,ircxy ) + call mpas_pool_get_array(output_noahmp,'irbxy' ,irbxy ) + call mpas_pool_get_array(output_noahmp,'trxy' ,trxy ) + call mpas_pool_get_array(output_noahmp,'evcxy' ,evcxy ) + call mpas_pool_get_array(output_noahmp,'chleafxy',chleafxy) + call mpas_pool_get_array(output_noahmp,'chucxy' ,chucxy ) + call mpas_pool_get_array(output_noahmp,'chv2xy' ,chv2xy ) + call mpas_pool_get_array(output_noahmp,'chb2xy' ,chb2xy ) + call mpas_pool_get_array(output_noahmp,'rs' ,rs ) + call mpas_pool_get_array(output_noahmp,'qtdrain',qtdrain ) + + do i = its,ite + mpas_noahmp%t2mvxy(i) = t2mvxy(i) + mpas_noahmp%t2mbxy(i) = t2mbxy(i) + mpas_noahmp%q2mvxy(i) = q2mvxy(i) + mpas_noahmp%q2mbxy(i) = q2mbxy(i) + mpas_noahmp%tradxy(i) = tradxy(i) + mpas_noahmp%neexy(i) = neexy(i) + mpas_noahmp%gppxy(i) = gppxy(i) + mpas_noahmp%nppxy(i) = nppxy(i) + mpas_noahmp%fvegxy(i) = fvegxy(i) + mpas_noahmp%runsfxy(i) = runsfxy(i) + mpas_noahmp%runsbxy(i) = runsbxy(i) + mpas_noahmp%ecanxy(i) = ecanxy(i) + mpas_noahmp%edirxy(i) = edirxy(i) + mpas_noahmp%etranxy(i) = etranxy(i) + mpas_noahmp%fsaxy(i) = fsaxy(i) + mpas_noahmp%firaxy(i) = firaxy(i) + mpas_noahmp%aparxy(i) = aparxy(i) + mpas_noahmp%psnxy(i) = psnxy(i) + mpas_noahmp%savxy(i) = savxy(i) + mpas_noahmp%sagxy(i) = sagxy(i) + mpas_noahmp%rssunxy(i) = rssunxy(i) + mpas_noahmp%rsshaxy(i) = rsshaxy(i) + mpas_noahmp%bgapxy(i) = bgapxy(i) + mpas_noahmp%wgapxy(i) = wgapxy(i) + mpas_noahmp%tgvxy(i) = tgvxy(i) + mpas_noahmp%tgbxy(i) = tgbxy(i) + mpas_noahmp%chvxy(i) = chvxy(i) + mpas_noahmp%chbxy(i) = chbxy(i) + mpas_noahmp%shgxy(i) = shgxy(i) + mpas_noahmp%shcxy(i) = shcxy(i) + mpas_noahmp%shbxy(i) = shbxy(i) + mpas_noahmp%evgxy(i) = evgxy(i) + mpas_noahmp%evbxy(i) = evbxy(i) + mpas_noahmp%ghvxy(i) = ghvxy(i) + mpas_noahmp%ghbxy(i) = ghbxy(i) + mpas_noahmp%irgxy(i) = irgxy(i) + mpas_noahmp%ircxy(i) = ircxy(i) + mpas_noahmp%irbxy(i) = irbxy(i) + mpas_noahmp%trxy(i) = trxy(i) + mpas_noahmp%evcxy(i) = evcxy(i) + mpas_noahmp%chleafxy(i) = chleafxy(i) + mpas_noahmp%chucxy(i) = chucxy(i) + mpas_noahmp%chv2xy(i) = chv2xy(i) + mpas_noahmp%chb2xy(i) = chb2xy(i) + mpas_noahmp%rs(i) = rs(i) + mpas_noahmp%qtdrain(i) = qtdrain(i) + enddo + + + !--- update of OUT additional variables, i.e. see lines 292-334 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(output_noahmp,'pahxy' ,pahxy ) + call mpas_pool_get_array(output_noahmp,'pahgxy' ,pahgxy ) + call mpas_pool_get_array(output_noahmp,'pahbxy' ,pahbxy ) + call mpas_pool_get_array(output_noahmp,'pahvxy' ,pahvxy ) + call mpas_pool_get_array(output_noahmp,'qintsxy' ,qintsxy ) + call mpas_pool_get_array(output_noahmp,'qintrxy' ,qintrxy ) + call mpas_pool_get_array(output_noahmp,'qdripsxy' ,qdripsxy ) + call mpas_pool_get_array(output_noahmp,'qdriprxy' ,qdriprxy ) + call mpas_pool_get_array(output_noahmp,'qthrosxy' ,qthrosxy ) + call mpas_pool_get_array(output_noahmp,'qthrorxy' ,qthrorxy ) + call mpas_pool_get_array(output_noahmp,'qsnsubxy' ,qsnsubxy ) + call mpas_pool_get_array(output_noahmp,'qmeltxy' ,qmeltxy ) + call mpas_pool_get_array(output_noahmp,'qsnfroxy' ,qsnfroxy ) + call mpas_pool_get_array(output_noahmp,'qsubcxy' ,qsubcxy ) + call mpas_pool_get_array(output_noahmp,'qfrocxy' ,qfrocxy ) + call mpas_pool_get_array(output_noahmp,'qevacxy' ,qevacxy ) + call mpas_pool_get_array(output_noahmp,'qdewcxy' ,qdewcxy ) + call mpas_pool_get_array(output_noahmp,'qfrzcxy' ,qfrzcxy ) + call mpas_pool_get_array(output_noahmp,'qmeltcxy' ,qmeltcxy ) + call mpas_pool_get_array(output_noahmp,'qsnbotxy' ,qsnbotxy ) + call mpas_pool_get_array(output_noahmp,'pondingxy' ,pondingxy ) + call mpas_pool_get_array(output_noahmp,'fpicexy' ,fpicexy ) + call mpas_pool_get_array(output_noahmp,'rainlsm' ,rainlsm ) + call mpas_pool_get_array(output_noahmp,'snowlsm' ,snowlsm ) + call mpas_pool_get_array(output_noahmp,'forctlsm' ,forctlsm ) + call mpas_pool_get_array(output_noahmp,'forcqlsm' ,forcqlsm ) + call mpas_pool_get_array(output_noahmp,'forcplsm' ,forcplsm ) + call mpas_pool_get_array(output_noahmp,'forczlsm' ,forczlsm ) + call mpas_pool_get_array(output_noahmp,'forcwlsm' ,forcwlsm ) + call mpas_pool_get_array(output_noahmp,'acc_ssoilxy' ,acc_ssoilxy ) + call mpas_pool_get_array(output_noahmp,'acc_qinsurxy',acc_qinsurxy ) + call mpas_pool_get_array(output_noahmp,'acc_qsevaxy' ,acc_qsevaxy ) + call mpas_pool_get_array(output_noahmp,'eflxbxy' ,eflxbxy ) + call mpas_pool_get_array(output_noahmp,'soilenergy' ,soilenergy ) + call mpas_pool_get_array(output_noahmp,'snowenergy' ,snowenergy ) + call mpas_pool_get_array(output_noahmp,'canhsxy' ,canhsxy ) + call mpas_pool_get_array(output_noahmp,'acc_dwaterxy',acc_dwaterxy ) + call mpas_pool_get_array(output_noahmp,'acc_prcpxy' ,acc_prcpxy ) + call mpas_pool_get_array(output_noahmp,'acc_ecanxy' ,acc_ecanxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranxy' ,acc_etranxy ) + call mpas_pool_get_array(output_noahmp,'acc_edirxy' ,acc_edirxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranixy',acc_etranixy ) + + do i = its,ite + mpas_noahmp%pahxy(i) = pahxy(i) + mpas_noahmp%pahgxy(i) = pahgxy(i) + mpas_noahmp%pahbxy(i) = pahbxy(i) + mpas_noahmp%pahvxy(i) = pahvxy(i) + mpas_noahmp%qintsxy(i) = qintsxy(i) + mpas_noahmp%qintrxy(i) = qintrxy(i) + mpas_noahmp%qdripsxy(i) = qdripsxy(i) + mpas_noahmp%qdriprxy(i) = qdriprxy(i) + mpas_noahmp%qthrosxy(i) = qthrosxy(i) + mpas_noahmp%qthrorxy(i) = qthrorxy(i) + mpas_noahmp%qsnsubxy(i) = qsnsubxy(i) + mpas_noahmp%qmeltxy(i) = qmeltxy(i) + mpas_noahmp%qsnfroxy(i) = qsnfroxy(i) + mpas_noahmp%qsubcxy(i) = qsubcxy(i) + mpas_noahmp%qfrocxy(i) = qfrocxy(i) + mpas_noahmp%qevacxy(i) = qevacxy(i) + mpas_noahmp%qdewcxy(i) = qdewcxy(i) + mpas_noahmp%qfrzcxy(i) = qfrzcxy(i) + mpas_noahmp%qmeltcxy(i) = qmeltcxy(i) + mpas_noahmp%qsnbotxy(i) = qsnbotxy(i) + mpas_noahmp%pondingxy(i) = pondingxy(i) + mpas_noahmp%fpicexy(i) = fpicexy(i) + mpas_noahmp%rainlsm(i) = rainlsm(i) + mpas_noahmp%snowlsm(i) = snowlsm(i) + mpas_noahmp%forctlsm(i) = forctlsm(i) + mpas_noahmp%forcqlsm(i) = forcqlsm(i) + mpas_noahmp%forcplsm(i) = forcplsm(i) + mpas_noahmp%forczlsm(i) = forczlsm(i) + mpas_noahmp%forcwlsm(i) = forcwlsm(i) + mpas_noahmp%acc_ssoilxy(i) = acc_ssoilxy(i) + mpas_noahmp%acc_qinsurxy(i) = acc_qinsurxy(i) + mpas_noahmp%acc_qsevaxy(i) = acc_qsevaxy(i) + mpas_noahmp%eflxbxy(i) = eflxbxy(i) + mpas_noahmp%soilenergy(i) = soilenergy(i) + mpas_noahmp%snowenergy(i) = snowenergy(i) + mpas_noahmp%canhsxy(i) = canhsxy(i) + mpas_noahmp%acc_dwaterxy(i) = acc_dwaterxy(i) + mpas_noahmp%acc_prcpxy(i) = acc_prcpxy(i) + mpas_noahmp%acc_ecanxy(i) = acc_ecanxy(i) + mpas_noahmp%acc_etranxy(i) = acc_etranxy(i) + mpas_noahmp%acc_edirxy(i) = acc_edirxy(i) +! real(kind=kind_noahmp), allocatable, dimension(:,:) :: acc_etranixy + enddo + +!call mpas_log_write('--- end subroutine lsm_noahmp_fromMPAS.') + + end subroutine lsm_noahmp_fromMPAS + +!================================================================================================================= + subroutine lsm_noahmp_sounding_fromMPAS(mesh,state,time_lev,diag) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + + integer,intent(in):: time_lev + + +!--- local variables and arrays: + integer:: i,its,ite,k,kts,kte + integer,pointer:: index_qv + + real(kind=RKIND),dimension(:,:),pointer:: zgrid + real(kind=RKIND),dimension(:,:),pointer:: qv,theta_m,u,v + real(kind=RKIND),dimension(:,:),pointer:: exner,pressure_b,pressure_p + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND):: fzm,fzp,mult,totm,totp + real(kind=RKIND):: w1,w2,z0,z1,z2 + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine lsm_noahmp_sounding_fromMPAS: $i',intArgs=(/time_lev/)) + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + kts = mpas_noahmp%kts + kte = mpas_noahmp%kte + + +!--- initialization of input sounding variables: + call mpas_pool_get_array(mesh,'zgrid',zgrid) + + call mpas_pool_get_array(diag,'exner' ,exner ) + call mpas_pool_get_array(diag,'pressure_base' ,pressure_b) + call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) + call mpas_pool_get_array(diag,'uReconstructZonal' ,u ) + call mpas_pool_get_array(diag,'uReconstructMeridional',v ) + + call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + qv => scalars(index_qv,:,:) + + do i = its,ite + do k = kts,kte + mpas_noahmp%dz8w(i,k) = zgrid(k+1,i)-zgrid(k,i) + mpas_noahmp%qv_curr(i,k) = qv(k,i) + mpas_noahmp%t_phy(i,k) = (theta_m(k,i)/(1.+R_v/R_d*qv(k,i)))*exner(k,i) + mpas_noahmp%u_phy(i,k) = u(k,i) + mpas_noahmp%v_phy(i,k) = v(k,i) + enddo + enddo + + +!--- initialization of pressure at interface between layers: + do i = its,ite + k = kts + z0 = zgrid(k,i) + z1 = 0.5*(zgrid(k,i)+zgrid(k+1,i)) + z2 = 0.5*(zgrid(k+1,i)+zgrid(k+2,i)) + w1 = (z0-z2)/(z1-z2) + w2 = 1.-w1 + totm = pressure_p(k,i)+pressure_b(k,i) + totp = pressure_p(k+1,i)+pressure_b(k+1,i) + mpas_noahmp%p8w(i,k) = w1*totm + w2*totp + + do k = kts+1,kte + totm = pressure_p(k-1,i)+pressure_b(k-1,i) + totp = pressure_p(k,i)+pressure_b(k,i) + mult = 1./(zgrid(k+1,i)-zgrid(k-1,i)) + fzm = mult*(zgrid(k,i)-zgrid(k-1,i)) + fzp = mult*(zgrid(k+1,i)-zgrid(k,i)) + mpas_noahmp%p8w(i,k) = fzm*totp + fzp*totm + enddo + enddo + +!call mpas_log_write('--- end subroutine lsm_noahmp_sounding_fromMPAS:') + + end subroutine lsm_noahmp_sounding_fromMPAS + +!================================================================================================================= + subroutine lsm_noahmp_toMPAS(diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + + +!--- local variables and arrays: + integer:: i,its,ite + integer:: n,ns,nsoil,nsnow,nzsnow + + +!--- local INOUT pointers (with generic LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: acsnom,acsnow,canwat,hfx,qfx,qsfc,lh,grdflx,sfc_albedo,sfc_emiss, & + sfcrunoff,skintemp,smstav,smstot,udrunoff,snow,snowc,snowh,lai,z0, & + znt + real(kind=RKIND),dimension(:,:),pointer:: sh2o,smois,tslb + + + !--- local INOUT pointers (with no Noah LSM equivalent as defined in WRF): + integer,dimension(:),pointer:: isnowxy + real(kind=RKIND),dimension(:),pointer:: tvxy,tgxy,canicexy,canliqxy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy, & + alboldxy,qsnowxy,qrainxy,wslakexy,zwtxy,waxy,wtxy,deeprechxy, & + rechxy,lfmassxy,rtmassxy,stmassxy,woodxy,grainxy,gddxy,stblcpxy, & + fastcpxy,xsaixy,taussxy + real(kind=RKIND),dimension(:,:),pointer:: tsnoxy,zsnsoxy,snicexy,snliqxy + + +!--- local OUT pointers (with no Noah LSM equivalent as defined in WRF): + real(kind=RKIND),dimension(:),pointer:: t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,runsfxy, & + runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy, & + rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy, & + shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy, & + chucxy,chv2xy,chb2xy,rs,qtdrain + + +!--- local OUT additional variables: + real(kind=RKIND),dimension(:),pointer:: pahxy,pahgxy,pahbxy,pahvxy,qintsxy,qintrxy,qdripsxy,qdriprxy, & + qthrosxy,qthrorxy,qsnsubxy,qmeltxy,qsnfroxy,qsubcxy,qfrocxy, & + qevacxy,qdewcxy,qfrzcxy,qmeltcxy,qsnbotxy,pondingxy,fpicexy, & + rainlsm,snowlsm,forctlsm,forcqlsm,forcplsm,forczlsm,forcwlsm, & + acc_ssoilxy,acc_qinsurxy,acc_qsevaxy,eflxbxy,soilenergy,snowenergy, & + canhsxy,acc_dwaterxy,acc_prcpxy,acc_ecanxy,acc_etranxy,acc_edirxy + real(kind=RKIND),dimension(:,:),pointer:: acc_etranixy + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine lsm_noahmp_toMPAS:') + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + nsoil = mpas_noahmp%nsoil + nsnow = mpas_noahmp%nsnow + nzsnow = nsnow + nsoil + + +!--- update of INOUT variables (with generic LSM equivalent as defined in WRF), i.e. see +! lines 162-184 in module NoahmpIOVarType.F90): + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + call mpas_pool_get_array(sfc_input,'snow' ,snow ) + call mpas_pool_get_array(sfc_input,'snowh' ,snowh ) + call mpas_pool_get_array(sfc_input,'sh2o' ,sh2o ) + call mpas_pool_get_array(sfc_input,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + 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,'grdflx' ,grdflx ) + 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,'sfcrunoff' ,sfcrunoff ) + call mpas_pool_get_array(diag_physics,'udrunoff' ,udrunoff ) + call mpas_pool_get_array(diag_physics,'sfc_albedo',sfc_albedo) + call mpas_pool_get_array(diag_physics,'canwat' ,canwat ) + 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,'sfc_emiss' ,sfc_emiss ) + call mpas_pool_get_array(diag_physics,'qsfc' ,qsfc ) + call mpas_pool_get_array(diag_physics,'lai' ,lai ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + + + do i = its,ite + skintemp(i) = mpas_noahmp%tsk(i) + hfx(i) = mpas_noahmp%hfx(i) + qfx(i) = mpas_noahmp%qfx(i) + lh(i) = mpas_noahmp%lh(i) + grdflx(i) = mpas_noahmp%grdflx(i) + smstav(i) = mpas_noahmp%smstav(i) + smstot(i) = mpas_noahmp%smstot(i) + sfcrunoff(i) = mpas_noahmp%sfcrunoff(i) + udrunoff(i) = mpas_noahmp%udrunoff(i) + sfc_albedo(i) = mpas_noahmp%albedo(i) + snowc(i) = mpas_noahmp%snowc(i) + snow(i) = mpas_noahmp%snow(i) + snowh(i) = mpas_noahmp%snowh(i) + canwat(i) = mpas_noahmp%canwat(i) + acsnom(i) = mpas_noahmp%acsnom(i) + acsnow(i) = mpas_noahmp%acsnow(i) + sfc_emiss(i) = mpas_noahmp%emiss(i) + qsfc(i) = mpas_noahmp%qsfc(i) + lai(i) = mpas_noahmp%lai(i) + z0(i) = mpas_noahmp%z0(i) + znt(i) = mpas_noahmp%znt(i) + enddo + + do ns = 1,nsoil + do i = its,ite + sh2o(ns,i) = mpas_noahmp%sh2o(i,ns) + smois(ns,i) = mpas_noahmp%smois(i,ns) + tslb(ns,i) = mpas_noahmp%tslb(i,ns) + enddo + enddo + + +!--- update of INOUT variables (with no Noah LSM equivalent as defined in WRF), i.e. see +! lines 186-222 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(diag_physics_noahmp,'isnowxy' ,isnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tvxy' ,tvxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tgxy' ,tgxy ) + call mpas_pool_get_array(diag_physics_noahmp,'canicexy' ,canicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'canliqxy' ,canliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'eahxy' ,eahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tahxy' ,tahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'cmxy' ,cmxy ) + call mpas_pool_get_array(diag_physics_noahmp,'chxy' ,chxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fwetxy' ,fwetxy ) + call mpas_pool_get_array(diag_physics_noahmp,'sneqvoxy' ,sneqvoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'alboldxy' ,alboldxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qsnowxy' ,qsnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qrainxy' ,qrainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wslakexy' ,wslakexy ) + call mpas_pool_get_array(diag_physics_noahmp,'zwtxy' ,zwtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'waxy' ,waxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wtxy' ,wtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'deeprechxy',deeprechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rechxy' ,rechxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tsnoxy' ,tsnoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'zsnsoxy' ,zsnsoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'snicexy' ,snicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'snliqxy' ,snliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'lfmassxy' ,lfmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rtmassxy' ,rtmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stmassxy' ,stmassxy ) + call mpas_pool_get_array(diag_physics_noahmp,'woodxy' ,woodxy ) + call mpas_pool_get_array(diag_physics_noahmp,'grainxy' ,grainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'gddxy' ,gddxy ) + call mpas_pool_get_array(diag_physics_noahmp,'stblcpxy' ,stblcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fastcpxy' ,fastcpxy ) + call mpas_pool_get_array(diag_physics_noahmp,'xsaixy' ,xsaixy ) + call mpas_pool_get_array(diag_physics_noahmp,'taussxy' ,taussxy ) + + do i = its,ite + isnowxy(i) = mpas_noahmp%isnowxy(i) + tvxy(i) = mpas_noahmp%tvxy(i) + tgxy(i) = mpas_noahmp%tgxy(i) + canicexy(i) = mpas_noahmp%canicexy(i) + canliqxy(i) = mpas_noahmp%canliqxy(i) + eahxy(i) = mpas_noahmp%eahxy(i) + tahxy(i) = mpas_noahmp%tahxy(i) + cmxy(i) = mpas_noahmp%cmxy(i) + chxy(i) = mpas_noahmp%chxy(i) + fwetxy(i) = mpas_noahmp%fwetxy(i) + sneqvoxy(i) = mpas_noahmp%sneqvoxy(i) + alboldxy(i) = mpas_noahmp%alboldxy(i) + qsnowxy(i) = mpas_noahmp%qsnowxy(i) + qrainxy(i) = mpas_noahmp%qrainxy(i) + wslakexy(i) = mpas_noahmp%wslakexy(i) + zwtxy(i) = mpas_noahmp%zwtxy(i) + waxy(i) = mpas_noahmp%waxy(i) + wtxy(i) = mpas_noahmp%wtxy(i) + deeprechxy(i) = mpas_noahmp%deeprechxy(i) + rechxy(i) = mpas_noahmp%rechxy(i) + lfmassxy(i) = mpas_noahmp%lfmassxy(i) + rtmassxy(i) = mpas_noahmp%rtmassxy(i) + stmassxy(i) = mpas_noahmp%stmassxy(i) + woodxy(i) = mpas_noahmp%woodxy(i) + grainxy(i) = mpas_noahmp%grainxy(i) + gddxy(i) = mpas_noahmp%gddxy(i) + stblcpxy(i) = mpas_noahmp%stblcpxy(i) + fastcpxy(i) = mpas_noahmp%fastcpxy(i) + xsaixy(i) = mpas_noahmp%xsaixy(i) + taussxy(i) = mpas_noahmp%taussxy(i) + + do ns = 1,nsnow + n = ns - nsnow + tsnoxy(ns,i) = mpas_noahmp%tsnoxy(i,n) + snicexy(ns,i) = mpas_noahmp%snicexy(i,n) + snliqxy(ns,i) = mpas_noahmp%snliqxy(i,n) + enddo + do ns = 1,nsnow + n = ns - nsnow + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + do ns = nsnow+1,nzsnow + n = ns - nsoil + 1 + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + enddo + + +!--- update of OUT (with no Noah LSM equivalent as defined in WRF), i.e. see +! lines 242-290 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(output_noahmp,'t2mvxy' ,t2mvxy ) + call mpas_pool_get_array(output_noahmp,'t2mbxy' ,t2mbxy ) + call mpas_pool_get_array(output_noahmp,'q2mvxy' ,q2mvxy ) + call mpas_pool_get_array(output_noahmp,'q2mbxy' ,q2mbxy ) + call mpas_pool_get_array(output_noahmp,'tradxy' ,tradxy ) + call mpas_pool_get_array(output_noahmp,'neexy' ,neexy ) + call mpas_pool_get_array(output_noahmp,'gppxy' ,gppxy ) + call mpas_pool_get_array(output_noahmp,'nppxy' ,nppxy ) + call mpas_pool_get_array(output_noahmp,'fvegxy' ,fvegxy ) + call mpas_pool_get_array(output_noahmp,'runsfxy' ,runsfxy ) + call mpas_pool_get_array(output_noahmp,'runsbxy' ,runsbxy ) + call mpas_pool_get_array(output_noahmp,'ecanxy' ,ecanxy ) + call mpas_pool_get_array(output_noahmp,'edirxy' ,edirxy ) + call mpas_pool_get_array(output_noahmp,'etranxy' ,etranxy ) + call mpas_pool_get_array(output_noahmp,'fsaxy' ,fsaxy ) + call mpas_pool_get_array(output_noahmp,'firaxy' ,firaxy ) + call mpas_pool_get_array(output_noahmp,'aparxy' ,aparxy ) + call mpas_pool_get_array(output_noahmp,'psnxy' ,psnxy ) + call mpas_pool_get_array(output_noahmp,'savxy' ,savxy ) + call mpas_pool_get_array(output_noahmp,'sagxy' ,sagxy ) + call mpas_pool_get_array(output_noahmp,'rssunxy' ,rssunxy ) + call mpas_pool_get_array(output_noahmp,'rsshaxy' ,rsshaxy ) + call mpas_pool_get_array(output_noahmp,'bgapxy' ,bgapxy ) + call mpas_pool_get_array(output_noahmp,'wgapxy' ,wgapxy ) + call mpas_pool_get_array(output_noahmp,'tgvxy' ,tgvxy ) + call mpas_pool_get_array(output_noahmp,'tgbxy' ,tgbxy ) + call mpas_pool_get_array(output_noahmp,'chvxy' ,chvxy ) + call mpas_pool_get_array(output_noahmp,'chbxy' ,chbxy ) + call mpas_pool_get_array(output_noahmp,'shgxy' ,shgxy ) + call mpas_pool_get_array(output_noahmp,'shcxy' ,shcxy ) + call mpas_pool_get_array(output_noahmp,'shbxy' ,shbxy ) + call mpas_pool_get_array(output_noahmp,'evgxy' ,evgxy ) + call mpas_pool_get_array(output_noahmp,'evbxy' ,evbxy ) + call mpas_pool_get_array(output_noahmp,'ghvxy' ,ghvxy ) + call mpas_pool_get_array(output_noahmp,'ghbxy' ,ghbxy ) + call mpas_pool_get_array(output_noahmp,'irgxy' ,irgxy ) + call mpas_pool_get_array(output_noahmp,'ircxy' ,ircxy ) + call mpas_pool_get_array(output_noahmp,'irbxy' ,irbxy ) + call mpas_pool_get_array(output_noahmp,'trxy' ,trxy ) + call mpas_pool_get_array(output_noahmp,'evcxy' ,evcxy ) + call mpas_pool_get_array(output_noahmp,'chleafxy',chleafxy) + call mpas_pool_get_array(output_noahmp,'chucxy' ,chucxy ) + call mpas_pool_get_array(output_noahmp,'chv2xy' ,chv2xy ) + call mpas_pool_get_array(output_noahmp,'chb2xy' ,chb2xy ) + call mpas_pool_get_array(output_noahmp,'rs' ,rs ) + call mpas_pool_get_array(output_noahmp,'qtdrain',qtdrain ) + + do i = its,ite + t2mvxy(i) = mpas_noahmp%t2mvxy(i) + t2mbxy(i) = mpas_noahmp%t2mbxy(i) + q2mvxy(i) = mpas_noahmp%q2mvxy(i) + q2mbxy(i) = mpas_noahmp%q2mbxy(i) + tradxy(i) = mpas_noahmp%tradxy(i) + neexy(i) = mpas_noahmp%neexy(i) + gppxy(i) = mpas_noahmp%gppxy(i) + nppxy(i) = mpas_noahmp%nppxy(i) + fvegxy(i) = mpas_noahmp%fvegxy(i) + runsfxy(i) = mpas_noahmp%runsfxy(i) + runsbxy(i) = mpas_noahmp%runsbxy(i) + ecanxy(i) = mpas_noahmp%ecanxy(i) + edirxy(i) = mpas_noahmp%edirxy(i) + etranxy(i) = mpas_noahmp%etranxy(i) + fsaxy(i) = mpas_noahmp%fsaxy(i) + firaxy(i) = mpas_noahmp%firaxy(i) + aparxy(i) = mpas_noahmp%aparxy(i) + psnxy(i) = mpas_noahmp%psnxy(i) + savxy(i) = mpas_noahmp%savxy(i) + sagxy(i) = mpas_noahmp%sagxy(i) + rssunxy(i) = mpas_noahmp%rssunxy(i) + rsshaxy(i) = mpas_noahmp%rsshaxy(i) + bgapxy(i) = mpas_noahmp%bgapxy(i) + wgapxy(i) = mpas_noahmp%wgapxy(i) + tgvxy(i) = mpas_noahmp%tgvxy(i) + tgbxy(i) = mpas_noahmp%tgbxy(i) + chvxy(i) = mpas_noahmp%chvxy(i) + chbxy(i) = mpas_noahmp%chbxy(i) + shgxy(i) = mpas_noahmp%shgxy(i) + shcxy(i) = mpas_noahmp%shcxy(i) + shbxy(i) = mpas_noahmp%shbxy(i) + evgxy(i) = mpas_noahmp%evgxy(i) + evbxy(i) = mpas_noahmp%evbxy(i) + ghvxy(i) = mpas_noahmp%ghvxy(i) + ghbxy(i) = mpas_noahmp%ghbxy(i) + irgxy(i) = mpas_noahmp%irgxy(i) + ircxy(i) = mpas_noahmp%ircxy(i) + irbxy(i) = mpas_noahmp%irbxy(i) + trxy(i) = mpas_noahmp%trxy(i) + evcxy(i) = mpas_noahmp%evcxy(i) + chleafxy(i) = mpas_noahmp%chleafxy(i) + chucxy(i) = mpas_noahmp%chucxy(i) + chv2xy(i) = mpas_noahmp%chv2xy(i) + chb2xy(i) = mpas_noahmp%chb2xy(i) + rs(i) = mpas_noahmp%rs(i) + qtdrain(i) = mpas_noahmp%qtdrain(i) + enddo + + +!--- update of OUT additional variables, i.e. see lines 292-334 in module NoahmpIOVarType.F90: + call mpas_pool_get_array(output_noahmp,'pahxy' ,pahxy ) + call mpas_pool_get_array(output_noahmp,'pahgxy' ,pahgxy ) + call mpas_pool_get_array(output_noahmp,'pahbxy' ,pahbxy ) + call mpas_pool_get_array(output_noahmp,'pahvxy' ,pahvxy ) + call mpas_pool_get_array(output_noahmp,'qintsxy' ,qintsxy ) + call mpas_pool_get_array(output_noahmp,'qintrxy' ,qintrxy ) + call mpas_pool_get_array(output_noahmp,'qdripsxy' ,qdripsxy ) + call mpas_pool_get_array(output_noahmp,'qdriprxy' ,qdriprxy ) + call mpas_pool_get_array(output_noahmp,'qthrosxy' ,qthrosxy ) + call mpas_pool_get_array(output_noahmp,'qthrorxy' ,qthrorxy ) + call mpas_pool_get_array(output_noahmp,'qsnsubxy' ,qsnsubxy ) + call mpas_pool_get_array(output_noahmp,'qmeltxy' ,qmeltxy ) + call mpas_pool_get_array(output_noahmp,'qsnfroxy' ,qsnfroxy ) + call mpas_pool_get_array(output_noahmp,'qsubcxy' ,qsubcxy ) + call mpas_pool_get_array(output_noahmp,'qfrocxy' ,qfrocxy ) + call mpas_pool_get_array(output_noahmp,'qevacxy' ,qevacxy ) + call mpas_pool_get_array(output_noahmp,'qdewcxy' ,qdewcxy ) + call mpas_pool_get_array(output_noahmp,'qfrzcxy' ,qfrzcxy ) + call mpas_pool_get_array(output_noahmp,'qmeltcxy' ,qmeltcxy ) + call mpas_pool_get_array(output_noahmp,'qsnbotxy' ,qsnbotxy ) + call mpas_pool_get_array(output_noahmp,'pondingxy' ,pondingxy ) + call mpas_pool_get_array(output_noahmp,'fpicexy' ,fpicexy ) + call mpas_pool_get_array(output_noahmp,'rainlsm' ,rainlsm ) + call mpas_pool_get_array(output_noahmp,'snowlsm' ,snowlsm ) + call mpas_pool_get_array(output_noahmp,'forctlsm' ,forctlsm ) + call mpas_pool_get_array(output_noahmp,'forcqlsm' ,forcqlsm ) + call mpas_pool_get_array(output_noahmp,'forcplsm' ,forcplsm ) + call mpas_pool_get_array(output_noahmp,'forczlsm' ,forczlsm ) + call mpas_pool_get_array(output_noahmp,'forcwlsm' ,forcwlsm ) + call mpas_pool_get_array(output_noahmp,'acc_ssoilxy' ,acc_ssoilxy ) + call mpas_pool_get_array(output_noahmp,'acc_qinsurxy',acc_qinsurxy ) + call mpas_pool_get_array(output_noahmp,'acc_qsevaxy' ,acc_qsevaxy ) + call mpas_pool_get_array(output_noahmp,'eflxbxy' ,eflxbxy ) + call mpas_pool_get_array(output_noahmp,'soilenergy' ,soilenergy ) + call mpas_pool_get_array(output_noahmp,'snowenergy' ,snowenergy ) + call mpas_pool_get_array(output_noahmp,'canhsxy' ,canhsxy ) + call mpas_pool_get_array(output_noahmp,'acc_dwaterxy',acc_dwaterxy ) + call mpas_pool_get_array(output_noahmp,'acc_prcpxy' ,acc_prcpxy ) + call mpas_pool_get_array(output_noahmp,'acc_ecanxy' ,acc_ecanxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranxy' ,acc_etranxy ) + call mpas_pool_get_array(output_noahmp,'acc_edirxy' ,acc_edirxy ) + call mpas_pool_get_array(output_noahmp,'acc_etranixy',acc_etranixy ) + + do i = its,ite + pahxy(i) = mpas_noahmp%pahxy(i) + pahgxy(i) = mpas_noahmp%pahgxy(i) + pahbxy(i) = mpas_noahmp%pahbxy(i) + pahvxy(i) = mpas_noahmp%pahvxy(i) + qintsxy(i) = mpas_noahmp%qintsxy(i) + qintrxy(i) = mpas_noahmp%qintrxy(i) + qdripsxy(i) = mpas_noahmp%qdripsxy(i) + qdriprxy(i) = mpas_noahmp%qdriprxy(i) + qthrosxy(i) = mpas_noahmp%qthrosxy(i) + qthrorxy(i) = mpas_noahmp%qthrorxy(i) + qsnsubxy(i) = mpas_noahmp%qsnsubxy(i) + qmeltxy(i) = mpas_noahmp%qmeltxy(i) + qsnfroxy(i) = mpas_noahmp%qsnfroxy(i) + qsubcxy(i) = mpas_noahmp%qsubcxy(i) + qfrocxy(i) = mpas_noahmp%qfrocxy(i) + qevacxy(i) = mpas_noahmp%qevacxy(i) + qdewcxy(i) = mpas_noahmp%qdewcxy(i) + qfrzcxy(i) = mpas_noahmp%qfrzcxy(i) + qmeltcxy(i) = mpas_noahmp%qmeltcxy(i) + qsnbotxy(i) = mpas_noahmp%qsnbotxy(i) + pondingxy(i) = mpas_noahmp%pondingxy(i) + fpicexy(i) = mpas_noahmp%fpicexy(i) + rainlsm(i) = mpas_noahmp%rainlsm(i) + snowlsm(i) = mpas_noahmp%snowlsm(i) + forctlsm(i) = mpas_noahmp%forctlsm(i) + forcqlsm(i) = mpas_noahmp%forcqlsm(i) + forcplsm(i) = mpas_noahmp%forcplsm(i) + forczlsm(i) = mpas_noahmp%forczlsm(i) + forcwlsm(i) = mpas_noahmp%forcwlsm(i) + acc_ssoilxy(i) = mpas_noahmp%acc_ssoilxy(i) + acc_qinsurxy(i) = mpas_noahmp%acc_qinsurxy(i) + acc_qsevaxy(i) = mpas_noahmp%acc_qsevaxy(i) + eflxbxy(i) = mpas_noahmp%eflxbxy(i) + soilenergy(i) = mpas_noahmp%soilenergy(i) + snowenergy(i) = mpas_noahmp%snowenergy(i) + canhsxy(i) = mpas_noahmp%canhsxy(i) + acc_dwaterxy(i) = mpas_noahmp%acc_dwaterxy(i) + acc_prcpxy(i) = mpas_noahmp%acc_prcpxy(i) + acc_ecanxy(i) = mpas_noahmp%acc_ecanxy(i) + acc_etranxy(i) = mpas_noahmp%acc_etranxy(i) + acc_edirxy(i) = mpas_noahmp%acc_edirxy(i) +! real(kind=kind_noahmp), allocatable, dimension(:,:) :: acc_etranixy + enddo + +!call mpas_log_write('--- end subroutine lsm_noahmp_toMPAS:') + + end subroutine lsm_noahmp_toMPAS + +!================================================================================================================= + subroutine driver_lsm_noahmp(configs,mesh,state,time_lev,diag,diag_physics,diag_physics_noahmp,output_noahmp, & + sfc_input,itimestep,its,ite) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + + integer,intent(in):: itimestep,its,ite + integer,intent(in):: time_lev + +!--- inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine driver_lsm_noahmp:') + + call lsm_noahmp_fromMPAS(configs,mesh,diag,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input, & + state,time_lev,itimestep) + + call NoahmpDriverMain(mpas_noahmp) + + call lsm_noahmp_toMPAS(diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + +!call mpas_log_write('--- end subroutine driver_lsm_noahmp:') + + end subroutine driver_lsm_noahmp + +!================================================================================================================= + end module mpas_atmphys_driver_lsm_noahmp +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F index 1d6e3235e6..067b4ef22f 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_microphysics.F @@ -10,7 +10,7 @@ module mpas_atmphys_driver_microphysics use mpas_kind_types use mpas_pool_routines use mpas_timer, only : mpas_timer_start, mpas_timer_stop - + use mpas_atmphys_constants use mpas_atmphys_init_microphysics use mpas_atmphys_interface @@ -19,14 +19,16 @@ module mpas_atmphys_driver_microphysics !wrf physics: use module_mp_kessler use module_mp_thompson - use module_mp_wsm6 + use module_mp_wsm6,only: wsm6 + use mp_wsm6,only: mp_wsm6_init,refl10cm_wsm6 + implicit none private public:: allocate_microphysics, & deallocate_microphysics, & driver_microphysics, & - microphysics_init + init_microphysics !MPAS driver for parameterization of cloud microphysics processes. @@ -47,7 +49,7 @@ module mpas_atmphys_driver_microphysics ! WRF physics called from microphysics_driver: ! -------------------------------------------- ! * module_mp_kessler : Kessler cloud microphysics. -! * module_mp_thompson: Thompson cloud microphysics. +! * module_mp_thompson: Thompson cloud microphysics. ! * module_mp_wsm6 : WSM6 cloud microphysics. ! ! comments: @@ -58,12 +60,12 @@ module mpas_atmphys_driver_microphysics ! ---------------------------------------- ! * removed call to the Thompson cloud microphysics scheme until scheme is updated to that in WRF revision 3.5. ! Laura D. Fowler (laura@ucar.edu) / 2013-05-29. -! * added subroutine compute_relhum to calculate the relative humidity using the functions rslf and rsif from +! * added subroutine compute_relhum to calculate the relative humidity using the functions rslf and rsif from ! the Thompson cloud microphysics scheme. -! Laura D. Fowler (laura@ucar.edu) / 2013-07-12. +! Laura D. Fowler (laura@ucar.edu) / 2013-07-12. ! * removed the argument tend from the call to microphysics_from_MPAS (not needed). ! Laura D. Fowler (laura@ucar.edu) / 2013-11-07. -! * in call to subroutine wsm6, replaced the variable g (that originally pointed to gravity) with gravity, +! * in call to subroutine wsm6, replaced the variable g (that originally pointed to gravity) with gravity, ! for simplicity. ! Laura D. Fowler (laura@ucar.edu) / 2014-03-21. ! * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. @@ -107,30 +109,29 @@ subroutine allocate_microphysics(configs) call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) !sounding variables: - if(.not.allocated(rho_p) ) allocate(rho_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(pi_p) ) allocate(pi_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(pres_p) ) allocate(pres_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(z_p) ) allocate(z_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(dz_p) ) allocate(dz_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(w_p) ) allocate(w_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rho_p) ) allocate(rho_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(th_p) ) allocate(th_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(pi_p) ) allocate(pi_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(pres_p)) allocate(pres_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(z_p) ) allocate(z_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(dz_p) ) allocate(dz_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(w_p) ) allocate(w_p(ims:ime,kms:kme,jms:jme) ) !mass mixing ratios: - if(.not.allocated(qv_p) ) allocate(qv_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qc_p) ) allocate(qc_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qr_p) ) allocate(qr_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qv_p)) allocate(qv_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qc_p)) allocate(qc_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qr_p)) allocate(qr_p(ims:ime,kms:kme,jms:jme)) !surface precipitation: if(.not.allocated(rainnc_p) ) allocate(rainnc_p(ims:ime,jms:jme) ) if(.not.allocated(rainncv_p)) allocate(rainncv_p(ims:ime,jms:jme)) - microp_select: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") !mass mixing ratios: - if(.not.allocated(qi_p) ) allocate(qi_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qs_p) ) allocate(qs_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(qg_p) ) allocate(qg_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qi_p)) allocate(qi_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qs_p)) allocate(qs_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(qg_p)) allocate(qg_p(ims:ime,kms:kme,jms:jme)) !surface precipitation: if(.not.allocated(sr_p) ) allocate(sr_p(ims:ime,jms:jme) ) @@ -140,28 +141,36 @@ subroutine allocate_microphysics(configs) if(.not.allocated(graupelncv_p)) allocate(graupelncv_p(ims:ime,jms:jme)) !cloud water,cloud ice,and snow effective radii: - if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(resnow_p) ) allocate(resnow_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(recloud_p)) allocate(recloud_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(resnow_p) ) allocate(resnow_p(ims:ime,kms:kme,jms:jme) ) - microp2_select: select case(microp_scheme) + !precipitation flux: + if(.not.allocated(rainprod_p)) allocate(rainprod_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(evapprod_p)) allocate(evapprod_p(ims:ime,kms:kme,jms:jme)) - case("mp_thompson") - !number concentrations: + microp2_select: select case(trim(microp_scheme)) + case("mp_thompson","mp_thompson_aerosols") if(.not.allocated(ntc_p)) allocate(ntc_p(ims:ime,jms:jme)) if(.not.allocated(muc_p)) allocate(muc_p(ims:ime,jms:jme)) if(.not.allocated(ni_p) ) allocate(ni_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(nr_p) ) allocate(nr_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(rainprod_p)) allocate(rainprod_p(ims:ime,kms:kme,jms:jme)) - if(.not.allocated(evapprod_p)) allocate(evapprod_p(ims:ime,kms:kme,jms:jme)) + microp3_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(.not.allocated(nifa2d_p)) allocate(nifa2d_p(ims:ime,jms:jme)) + if(.not.allocated(nwfa2d_p)) allocate(nwfa2d_p(ims:ime,jms:jme)) + if(.not.allocated(nc_p) ) allocate(nc_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(nifa_p) ) allocate(nifa_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(nwfa_p) ) allocate(nwfa_p(ims:ime,kms:kme,jms:jme)) - case default + case default + end select microp3_select + case default end select microp2_select case default - end select microp_select end subroutine allocate_microphysics @@ -181,67 +190,74 @@ subroutine deallocate_microphysics(configs) call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) !sounding variables: - if(allocated(rho_p) ) deallocate(rho_p ) - if(allocated(th_p) ) deallocate(th_p ) - if(allocated(pi_p) ) deallocate(pi_p ) - if(allocated(pres_p) ) deallocate(pres_p ) - if(allocated(z_p) ) deallocate(z_p ) - if(allocated(dz_p) ) deallocate(dz_p ) - if(allocated(w_p) ) deallocate(w_p ) + if(allocated(rho_p) ) deallocate(rho_p ) + if(allocated(th_p) ) deallocate(th_p ) + if(allocated(pi_p) ) deallocate(pi_p ) + if(allocated(pres_p)) deallocate(pres_p) + if(allocated(z_p) ) deallocate(z_p ) + if(allocated(dz_p) ) deallocate(dz_p ) + if(allocated(w_p) ) deallocate(w_p ) !mass mixing ratios: - if(allocated(qv_p) ) deallocate(qv_p ) - if(allocated(qc_p) ) deallocate(qc_p ) - if(allocated(qr_p) ) deallocate(qr_p ) + if(allocated(qv_p)) deallocate(qv_p) + if(allocated(qc_p)) deallocate(qc_p) + if(allocated(qr_p)) deallocate(qr_p) !surface precipitation: - if(allocated(rainnc_p) ) deallocate(rainnc_p ) - if(allocated(rainncv_p) ) deallocate(rainncv_p ) - - microp_select: select case(microp_scheme) + if(allocated(rainnc_p) ) deallocate(rainnc_p ) + if(allocated(rainncv_p)) deallocate(rainncv_p) - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") !mass mixing ratios: - if(allocated(qi_p) ) deallocate(qi_p ) - if(allocated(qs_p) ) deallocate(qs_p ) - if(allocated(qg_p) ) deallocate(qg_p ) + if(allocated(qi_p)) deallocate(qi_p) + if(allocated(qs_p)) deallocate(qs_p) + if(allocated(qg_p)) deallocate(qg_p) !surface precipitation: - if(allocated(sr_p) ) deallocate(sr_p ) - if(allocated(snownc_p) ) deallocate(snownc_p ) - if(allocated(snowncv_p) ) deallocate(snowncv_p ) - if(allocated(graupelnc_p) ) deallocate(graupelnc_p ) - if(allocated(graupelncv_p) ) deallocate(graupelncv_p ) + if(allocated(sr_p) ) deallocate(sr_p ) + if(allocated(snownc_p) ) deallocate(snownc_p ) + if(allocated(snowncv_p) ) deallocate(snowncv_p ) + if(allocated(graupelnc_p) ) deallocate(graupelnc_p ) + if(allocated(graupelncv_p)) deallocate(graupelncv_p) !cloud water,cloud ice,and snow effective radii: - if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) - if(.not.allocated(resnow_p) ) allocate(resnow_p(ims:ime,kms:kme,jms:jme) ) + if(allocated(recloud_p)) deallocate(recloud_p) + if(allocated(reice_p) ) deallocate(reice_p ) + if(allocated(resnow_p) ) deallocate(resnow_p ) - microp2_select: select case(microp_scheme) + !precipitation flux: + if(allocated(rainprod_p)) deallocate(rainprod_p) + if(allocated(evapprod_p)) deallocate(evapprod_p) - case("mp_thompson") - !number concentrations: + microp2_select: select case(trim(microp_scheme)) + case("mp_thompson","mp_thompson_aerosols") if(allocated(ntc_p)) deallocate(ntc_p) if(allocated(muc_p)) deallocate(muc_p) if(allocated(ni_p) ) deallocate(ni_p ) if(allocated(nr_p) ) deallocate(nr_p ) - if(allocated(rainprod_p)) deallocate(rainprod_p) - if(allocated(evapprod_p)) deallocate(evapprod_p) + microp3_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(allocated(nifa2d_p)) deallocate(nifa2d_p) + if(allocated(nwfa2d_p)) deallocate(nwfa2d_p) + if(allocated(nc_p) ) deallocate(nc_p ) + if(allocated(nifa_p) ) deallocate(nifa_p ) + if(allocated(nwfa_p) ) deallocate(nwfa_p ) - case default + case default + end select microp3_select + case default end select microp2_select case default - end select microp_select end subroutine deallocate_microphysics !================================================================================================================= - subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) + subroutine init_microphysics(dminfo,configs,mesh,state,time_lev,sfc_input,diag_physics) !================================================================================================================= !input arguments: @@ -249,36 +265,60 @@ subroutine microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: sfc_input + integer,intent(in):: time_lev !inout arguments: type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: state !local pointer: + logical,pointer:: do_restart character(len=StrKIND),pointer:: microp_scheme +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine init_microphysics:') + +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_do_restart' ,do_restart ) + + microp_select: select case(trim(microp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call thompson_init(l_mp_tables) + call init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) - microp_select: select case(microp_scheme) + microp2_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + call init_thompson_aerosols_forMPAS(do_restart,dminfo,mesh,state,time_lev,diag_physics) - case("mp_thompson") - call thompson_init(l_mp_tables) - call init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) + case default + end select microp2_select - case("mp_wsm6") - call wsm6init(rho_a,rho_r,rho_s,cliq,cpv,hail_opt,.false.) + case("mp_wsm6") + call mp_wsm6_init(den0=rho_a,denr=rho_r,dens=rho_s,cl=cliq,cpv=cpv, & + hail_opt=hail_opt,errmsg=errmsg,errflg=errflg) - case default - - end select microp_select + case default + end select microp_select - end subroutine microphysics_init +!call mpas_log_write('--- end subroutine init_microphysics:') + + end subroutine init_microphysics !================================================================================================================= - subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,tend,itimestep,its,ite) !================================================================================================================= + use mpas_constants, only : rvord + !input arguments: type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh @@ -286,24 +326,32 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten integer,intent(in):: time_lev integer,intent(in):: itimestep integer,intent(in):: its,ite - + !inout arguments: type(mpas_pool_type),intent(inout):: state type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics type(mpas_pool_type),intent(inout):: tend !local pointers: character(len=StrKIND),pointer:: microp_scheme !local variables and arrays: - logical:: log_microphysics - integer:: i,icell,icount,istep,j,k,kk + integer:: istep + +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('---enter subroutine driver_microphysics:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) !... allocation of microphysics arrays: @@ -316,13 +364,12 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten call precip_from_MPAS(configs,diag_physics,its,ite) !... initialization of soundings for non-hydrostatic dynamical cores. - call microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) + call microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,its,ite) !... call to different cloud microphysics schemes: - microp_select: select case(microp_scheme) - + microp_select: select case(trim(microp_scheme)) case ("mp_kessler") - call mpas_timer_start('Kessler') + call mpas_timer_start('mp_kessler') call kessler( & t = th_p , qv = qv_p , qc = qc_p , & qr = qr_p , rho = rho_p , pii = pi_p , & @@ -335,66 +382,94 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten 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('Kessler') + call mpas_timer_stop('mp_kessler') case ("mp_thompson") + call mpas_timer_start('mp_thompson') istep = 1 - call mpas_timer_start('Thompson') do while (istep .le. n_microp) call mp_gt_driver( & th = th_p , qv = qv_p , qc = qc_p , & qr = qr_p , qi = qi_p , qs = qs_p , & qg = qg_p , ni = ni_p , nr = nr_p , & - pii = pi_p , p = pres_p , dz = dz_p , & + pii = pi_p , p = pres_p , dz = dz_p , & w = w_p , dt_in = dt_microp , itimestep = itimestep , & rainnc = rainnc_p , rainncv = rainncv_p , snownc = snownc_p , & snowncv = snowncv_p , graupelnc = graupelnc_p , graupelncv = graupelncv_p , & sr = sr_p , rainprod = rainprod_p , evapprod = evapprod_p , & re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & - ntc = ntc_p , muc = muc_p , & + ntc = ntc_p , muc = muc_p , & 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 & ) istep = istep + 1 enddo - call mpas_timer_stop('Thompson') + call mpas_timer_stop('mp_thompson') + + case ("mp_thompson_aerosols") + call mpas_timer_start('mp_thompson_aerosols') + istep = 1 + do while (istep .le. n_microp) + call mp_gt_driver( & + th = th_p , qv = qv_p , qc = qc_p , & + qr = qr_p , qi = qi_p , qs = qs_p , & + qg = qg_p , ni = ni_p , nr = nr_p , & + pii = pi_p , p = pres_p , dz = dz_p , & + w = w_p , dt_in = dt_microp , itimestep = itimestep , & + rainnc = rainnc_p , rainncv = rainncv_p , snownc = snownc_p , & + snowncv = snowncv_p , graupelnc = graupelnc_p , graupelncv = graupelncv_p , & + sr = sr_p , rainprod = rainprod_p , evapprod = evapprod_p , & + re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & + has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & + nc = nc_p , nifa = nifa_p , nwfa = nwfa_p , & + nifa2d = nifa2d_p , nwfa2d = nwfa2d_p , ntc = ntc_p , & + muc = muc_p , & + 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 & + ) + istep = istep + 1 + enddo + call mpas_timer_stop('mp_thompson_aerosols') case ("mp_wsm6") - call mpas_timer_start('WSM6') + call mpas_timer_start('mp_wsm6') call wsm6( & - th = th_p , q = qv_p , qc = qc_p , & - qr = qr_p , qi = qi_p , qs = qs_p , & - qg = qg_p , den = rho_p , pii = pi_p , & - p = pres_p , delz = dz_p , delt = dt_microp , & - g = gravity , cpd = cp , cpv = cpv , & - rd = R_d , rv = R_v , t0c = svpt0 , & - ep1 = ep_1 , ep2 = ep_2 , qmin = epsilon , & - xls = xls , xlv0 = xlv , xlf0 = xlf , & - den0 = rho_a , denr = rho_w , cliq = cliq , & - cice = cice , psat = psat , rain = rainnc_p , & - rainncv = rainncv_p , snow = snownc_p , snowncv = snowncv_p , & - graupel = graupelnc_p , graupelncv = graupelncv_p , sr = sr_p , & - re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & - has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & - 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 & + th = th_p , q = qv_p , qc = qc_p , & + qr = qr_p , qi = qi_p , qs = qs_p , & + qg = qg_p , den = rho_p , pii = pi_p , & + p = pres_p , delz = dz_p , delt = dt_microp , & + g = gravity , cpd = cp , cpv = cpv , & + rd = R_d , rv = R_v , t0c = svpt0 , & + ep1 = ep_1 , ep2 = ep_2 , qmin = epsilon , & + xls = xls , xlv0 = xlv , xlf0 = xlf , & + den0 = rho_a , denr = rho_w , cliq = cliq , & + cice = cice , psat = psat , rain = rainnc_p , & + rainncv = rainncv_p , snow = snownc_p , snowncv = snowncv_p , & + graupel = graupelnc_p , graupelncv = graupelncv_p , sr = sr_p , & + re_cloud = recloud_p , re_ice = reice_p , re_snow = resnow_p , & + has_reqc = has_reqc , has_reqi = has_reqi , has_reqs = has_reqs , & + re_qc_bg = re_qc_bg , re_qi_bg = re_qi_bg , re_qs_bg = re_qs_bg , & + re_qc_max = re_qc_max , re_qi_max = re_qi_max , re_qs_max = re_qs_max , & + 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 & ) - call mpas_timer_stop('WSM6') + call mpas_timer_stop('mp_wsm6') case default - end select microp_select !... calculate the 10cm radar reflectivity and relative humidity, if needed: if (l_diags) then - !ensure that we only call compute_radar_reflectivity() if we are using an MPS that supports !the computation of simulated radar reflectivity: if(trim(microp_scheme) == "mp_wsm6" .or. & - trim(microp_scheme) == "mp_thompson") then + trim(microp_scheme) == "mp_thompson" .or. & + trim(microp_scheme) == "mp_thompson_aerosols") then call compute_radar_reflectivity(configs,diag_physics,its,ite) else call mpas_log_write('*** NOTICE: NOT computing simulated radar reflectivity') @@ -404,7 +479,6 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !calculate the relative humidity over water if the temperature is strictly greater than 0.C, !over ice otherwise. call compute_relhum(diag,its,ite) - end if !... copy updated precipitation from the wrf-physics grid back to the geodesic-dynamics grid: @@ -412,7 +486,7 @@ subroutine driver_microphysics(configs,mesh,state,time_lev,diag,diag_physics,ten !... copy updated cloud microphysics variables from the wrf-physics grid back to the geodesic- ! dynamics grid: - call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + call microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,tend,its,ite) !... deallocation of all microphysics arrays: !$OMP BARRIER @@ -439,7 +513,7 @@ subroutine precip_from_MPAS(configs,diag_physics,its,ite) !local pointers: character(len=StrKIND),pointer:: microp_scheme integer,pointer:: nCellsSolve - real,dimension(:),pointer:: graupelncv,rainncv,snowncv,sr + real,dimension(:),pointer:: graupelncv,rainncv,snowncv,sr !local variables and arrays: integer:: i,j @@ -466,9 +540,8 @@ subroutine precip_from_MPAS(configs,diag_physics,its,ite) enddo !variables specific to different cloud microphysics schemes: - microp_select: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") do j = jts, jte do i = its, ite snowncv_p(i,j) = 0._RKIND @@ -483,10 +556,9 @@ subroutine precip_from_MPAS(configs,diag_physics,its,ite) snowncv(i) = 0._RKIND graupelncv(i) = 0._RKIND sr(i) = 0._RKIND - enddo + enddo case default - end select microp_select end subroutine precip_from_MPAS @@ -531,7 +603,7 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) call mpas_pool_get_array(diag_physics,'sr' ,sr ) do i = its,ite - precipw(i) = 0._RKIND + precipw(i) = 0._RKIND enddo !variables common to all cloud microphysics schemes: @@ -546,7 +618,7 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) !time-step precipitation: rainncv(i) = rainnc_p(i,j) - + !accumulated precipitation: rainnc(i) = rainnc(i) + rainncv(i) @@ -555,14 +627,13 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) i_rainnc(i) = i_rainnc(i) + 1 rainnc(i) = rainnc(i) - config_bucket_rainnc endif - + enddo enddo !variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") + microp_select: select case(trim(microp_scheme)) + case ("mp_thompson","mp_thompson_aerosols","mp_wsm6") do j = jts,jte do i = its,ite !time-step precipitation: @@ -577,8 +648,7 @@ subroutine precip_to_MPAS(configs,diag_physics,its,ite) enddo case default - - end select microp_select_init + end select microp_select end subroutine precip_to_MPAS @@ -610,8 +680,7 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) call mpas_pool_get_array(diag_physics,'refl10cm_1km',refl10cm_1km) call mpas_pool_get_array(diag_physics,'refl10cm_1km_max',refl10cm_1km_max) - microp_select: select case(microp_scheme) - + microp_select: select case(trim(microp_scheme)) case ("mp_kessler") call physics_error_fatal('--- calculation of radar reflectivity is not available' // & 'with kessler cloud microphysics') @@ -636,10 +705,10 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) qs1d(k) = qs_p(i,k,j) qg1d(k) = qg_p(i,k,j) dBZ1d(k) = -35._RKIND - zp(k) = z_p(i,k,j) - z_p(i,1,j)+0.5*dz_p(i,1,j) ! height AGL + zp(k) = z_p(i,k,j) - z_p(i,1,j) + 0.5*dz_p(i,k,j) ! height AGL enddo - call refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d,kts,kte,i,j) + call refl10cm_wsm6(qv1d,qr1d,qs1d,qg1d,t1d,p1d,dBZ1d,kts,kte) kp = 1 do k = kts,kte @@ -663,7 +732,7 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) if(allocated(dBz1d)) deallocate(dBZ1d) if(allocated(zp) ) deallocate(zp ) - case ("mp_thompson") + case ("mp_thompson","mp_thompson_aerosols") if(.not.allocated(p1d) ) allocate(p1d(kts:kte) ) if(.not.allocated(t1d) ) allocate(t1d(kts:kte) ) if(.not.allocated(qv1d) ) allocate(qv1d(kts:kte) ) @@ -687,7 +756,7 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) qg1d(k) = qg_p(i,k,j) nr1d(k) = nr_p(i,k,j) dBZ1d(k) = -35._RKIND - zp(k) = z_p(i,k,j) - z_p(i,1,j)+0.5*dz_p(i,1,j) ! height AGL + zp(k) = z_p(i,k,j) - z_p(i,1,j) + 0.5*dz_p(i,k,j) ! height AGL enddo call calc_refl10cm(qv1d,qc1d,qr1d,nr1d,qs1d,qg1d,t1d,p1d,dBZ1d,kts,kte,i,j) @@ -717,7 +786,6 @@ subroutine compute_radar_reflectivity(configs,diag_physics,its,ite) if(allocated(zp) ) deallocate(zp ) case default - end select microp_select end subroutine compute_radar_reflectivity diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F index eaa898f980..5f2a860089 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_oml.F @@ -127,7 +127,7 @@ subroutine driver_oml1d(configs,mesh,diag,diag_physics,sfc_input) ! if ocean point, call the 1d ocean mixed layer model if( xland(iCell) .gt. 1.5) then - f_coriolis = 2.*omega*cos(latCell(iCell)) + f_coriolis = 2.*omega*sin(latCell(iCell)) call oml1d( t_oml(iCell), t_oml_initial(iCell), h_oml(iCell), h_oml_initial(iCell), & hu_oml(iCell), hv_oml(iCell), skintemp(iCell), hfx(iCell), & lh(iCell), gsw(iCell), glw(iCell), t_oml_200m_initial(iCell), & diff --git a/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F b/src/core_atmosphere/physics/mpas_atmphys_driver_pbl.F index 75d075ac3f..72a411aeba 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. @@ -60,12 +61,23 @@ module mpas_atmphys_driver_pbl ! * for the mynn parameterization, change the definition of dx_p to match that used in other physics ! parameterizations. ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. -! * updated the call to subroutine ysu in comjunction with updating module_bl_ysu.F from WRF version 3.6.1 to +! * updated the call to subroutine ysu in conjunction with updating module_bl_ysu.F from WRF version 3.6.1 to ! WRF version 3.8.1 ! Laura D. Fowler (laura@ucar.edu) / 2016-10-27. ! * since we removed the local variable pbl_scheme from mpas_atmphys_vars.F, now defines pbl_scheme as a pointer ! to config_pbl_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! * after updating module_bl_ysu.F to WRF version 4.0.3, corrected call to subroutine ysu to output diagnostics of +! exchange coefficients exch_h and exch_m. +! Laura D. Fowler (laura@ucar.edu) / 2019-03-12. +! * updated the call to subroutine ysu after updating the YSU PBL scheme to that in WRF 4.4.1. added the flags +! 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 @@ -93,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) ) @@ -107,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)) @@ -119,40 +130,61 @@ subroutine allocate_pbl(configs) 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(regime_p)) allocate(regime_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(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(rncblten_p) ) allocate(rncblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rniblten_p) ) allocate(rniblten_p(ims:ime,kms:kme,jms:jme) ) + if(.not.allocated(rnifablten_p)) allocate(rnifablten_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(rnwfablten_p)) allocate(rnwfablten_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 @@ -182,8 +214,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 ) @@ -195,6 +225,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) @@ -207,39 +239,62 @@ subroutine deallocate_pbl(configs) 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(regime_p)) deallocate(regime_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(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(rncblten_p) ) deallocate(rncblten_p ) + if(allocated(rniblten_p) ) deallocate(rniblten_p ) + if(allocated(rnifablten_p)) deallocate(rnifablten_p) + if(allocated(rnwfablten_p)) deallocate(rnwfablten_p) + + !deallocation of additional arrays: + if(allocated(pattern_spp_pbl)) deallocate(pattern_spp_pbl) case default @@ -271,47 +326,54 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it !local pointers for YSU scheme: logical,pointer:: config_ysu_pblmix - real(kind=RKIND),dimension(:),pointer:: br,fh,fm,regime,u10,v10 + real(kind=RKIND),dimension(:),pointer:: br,fh,fm,u10,v10 real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw !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)) @@ -319,15 +381,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,'regime',regime) - 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 @@ -338,9 +398,10 @@ subroutine pbl_from_MPAS(configs,mesh,sfc_input,diag_physics,tend_physics,its,it br_p(i,j) = br(i) psim_p(i,j) = fm(i) psih_p(i,j) = fh(i) - regime_p(i,j) = regime(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 @@ -350,8 +411,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 @@ -360,31 +420,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 @@ -399,15 +468,40 @@ 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) - 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 + 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 + rncblten_p(i,k,j) = 0._RKIND + rniblten_p(i,k,j) = 0._RKIND + rnifablten_p(i,k,j) = 0._RKIND + rnwfablten_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 @@ -425,9 +519,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 @@ -457,16 +551,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:: rncblten,rniblten,rnifablten,rnwfablten !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 !----------------------------------------------------------------------------------------------------------------- @@ -477,8 +574,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 ) @@ -489,10 +584,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 @@ -508,7 +601,7 @@ subroutine pbl_to_MPAS(configs,diag_physics,tend_physics,its,ite) kzh(k,i) = kzh_p(i,k,j) kzm(k,i) = kzm_p(i,k,j) - kzq(k,i) = kzq_p(i,k,j) + kzq(k,i) = kzh_p(i,k,j) enddo enddo enddo @@ -516,9 +609,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) @@ -527,50 +626,133 @@ 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 ) 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) enddo enddo enddo + if(f_ni) then + call mpas_pool_get_array(tend_physics,'rniblten',rniblten) + do j = jts,jte + do k = kts,kte + do i = its,ite + rniblten(k,i) = rniblten_p(i,k,j) + enddo + enddo + enddo + endif + if(f_nc .and. f_nifa .and. f_nwfa) then + call mpas_pool_get_array(tend_physics,'rncblten' ,rncblten ) + call mpas_pool_get_array(tend_physics,'rnifablten',rnifablten) + call mpas_pool_get_array(tend_physics,'rnwfablten',rnwfablten) + do j = jts,jte + do k = kts,kte + do i = its,ite + rncblten(k,i) = rncblten_p(i,k,j) + rnifablten(k,i) = rnifablten_p(i,k,j) + rnwfablten(k,i) = rnwfablten_p(i,k,j) + enddo + enddo + enddo + endif + case default end select pbl_select 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_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) !================================================================================================================= @@ -588,19 +770,49 @@ 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 +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_pbl:') - call mpas_pool_get_config(configs,'config_do_restart',config_do_restart) - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme ) +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + + 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) @@ -611,14 +823,14 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics pbl_select: select case (trim(pbl_scheme)) case("bl_ysu") - call mpas_timer_start('YSU') + call mpas_timer_start('bl_ysu') call ysu ( & p3d = pres_hyd_p , p3di = pres2_hyd_p , psfc = psfc_p , & - th3d = th_p , t3d = t_p , dz8w = dz_p , & - pi3d = pi_p , u3d = u_p , v3d = v_p , & - qv3d = qv_p , qc3d = qc_p , qi3d = qi_p , & - rublten = rublten_p , rvblten = rvblten_p , rthblten = rthblten_p , & - rqvblten = rqvblten_p , rqcblten = rqcblten_p , rqiblten = rqiblten_p , & + t3d = t_p , dz8w = dz_p , pi3d = pi_p , & + u3d = u_p , v3d = v_p , qv3d = qv_p , & + qc3d = qc_p , qi3d = qi_p , rublten = rublten_p , & + rvblten = rvblten_p , rthblten = rthblten_p , rqvblten = rqvblten_p , & + rqcblten = rqcblten_p , rqiblten = rqiblten_p , flag_qc = f_qc , & flag_qi = f_qi , cp = cp , g = gravity , & rovcp = rcp , rd = R_d , rovg = rdg , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & @@ -626,51 +838,128 @@ subroutine driver_pbl(itimestep,configs,mesh,sfc_input,diag_physics,tend_physics ust = ust_p , hpbl = hpbl_p , psim = psim_p , & psih = psih_p , xland = xland_p , hfx = hfx_p , & qfx = qfx_p , wspd = wspd_p , br = br_p , & - dt = dt_pbl , kpbl2d = kpbl_p , exch_h = exch_p , & - wstar = wstar_p , delta = delta_p , uoce = uoce_p , & - voce = voce_p , rthraten = rthraten_p , u10 = u10_p , & - v10 = v10_p , ctopo = ctopo_p , ctopo2 = ctopo2_p , & - regime = regime_p , rho = rho_p , kzhout = kzh_p , & - kzmout = kzm_p , kzqout = kzq_p , & + dt = dt_pbl , kpbl2d = kpbl_p , exch_h = kzh_p , & + exch_m = kzm_p , wstar = wstar_p , delta = delta_p , & + uoce = uoce_p , voce = voce_p , rthraten = rthraten_p , & + u10 = u10_p , v10 = v10_p , ctopo = ctopo_p , & + ctopo2 = ctopo2_p , flag_bep = flag_bep , idiff = idiff , & ysu_topdown_pblmix = ysu_pblmix , & + 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 & ) - call mpas_timer_stop('YSU') + 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 , nc = nc_p , & + ni = ni_p , nifa = nifa_p , nwfa = nwfa_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 , rncblten = rncblten_p , & + rniblten = rniblten_p , rnifablten = rnifablten_p , rnwfablten = rnwfablten_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..d4d271e50d 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_lw.F @@ -9,7 +9,7 @@ module mpas_atmphys_driver_radiation_lw 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_driver_radiation_sw, only: radconst use mpas_atmphys_constants @@ -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 @@ -136,7 +138,6 @@ subroutine allocate_radiation_lw(configs,xtime_s) if(.not.allocated(rthratenlw_p) ) allocate(rthratenlw_p(ims:ime,kms:kme,jms:jme) ) radiation_lw_select: select case (trim(radt_lw_scheme)) - case("rrtmg_lw") if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme) ) @@ -200,7 +201,6 @@ subroutine allocate_radiation_lw(configs,xtime_s) endif case default - end select radiation_lw_select end subroutine allocate_radiation_lw @@ -241,7 +241,6 @@ subroutine deallocate_radiation_lw(configs) if(allocated(rthratenlw_p) ) deallocate(rthratenlw_p ) radiation_lw_select: select case (trim(radt_lw_scheme)) - case("rrtmg_lw") if(allocated(recloud_p) ) deallocate(recloud_p ) if(allocated(reice_p) ) deallocate(reice_p ) @@ -290,7 +289,6 @@ subroutine deallocate_radiation_lw(configs) if(allocated(aerosolcp_p) ) deallocate(aerosolcp_p ) case default - end select radiation_lw_select end subroutine deallocate_radiation_lw @@ -318,9 +316,9 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !local pointers: logical,pointer:: config_o3climatology + logical,pointer:: config_microp_re character(len=StrKIND),pointer:: radt_lw_scheme character(len=StrKIND),pointer:: microp_scheme - logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland @@ -337,10 +335,10 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) - call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -413,10 +411,9 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi enddo radiation_lw_select: select case (trim(radt_lw_scheme)) - case("rrtmg_lw") microp_select: select case(microp_scheme) - case("mp_thompson","mp_wsm6") + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") if(config_microp_re) then call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) @@ -608,7 +605,6 @@ subroutine radiation_lw_from_MPAS(xtime_s,configs,mesh,state,time_lev,diag_physi enddo case default - end select radiation_lw_select end subroutine radiation_lw_from_MPAS @@ -627,9 +623,9 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) integer,intent(in):: its,ite !local pointers: + logical,pointer:: config_microp_re character(len=StrKIND),pointer:: radt_lw_scheme character(len=StrKIND),pointer:: microp_scheme - logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: glw,lwcf,lwdnb,lwdnbc,lwdnt,lwdntc,lwupb,lwupbc, & lwupt,lwuptc,olrtoa @@ -643,9 +639,9 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) - call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re) + call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme ) call mpas_pool_get_array(diag_physics,'glw' ,glw ) call mpas_pool_get_array(diag_physics,'lwcf' ,lwcf ) @@ -688,7 +684,7 @@ subroutine radiation_lw_to_MPAS(configs,diag_physics,tend_physics,its,ite) case("rrtmg_lw") microp_select: select case(microp_scheme) - case("mp_thompson","mp_wsm6") + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") call mpas_pool_get_array(diag_physics,'rre_cloud',rre_cloud) call mpas_pool_get_array(diag_physics,'rre_ice' ,rre_ice ) call mpas_pool_get_array(diag_physics,'rre_snow' ,rre_snow ) @@ -793,7 +789,6 @@ subroutine init_radiation_lw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta call mpas_pool_get_config(configs,'config_radt_lw_scheme',radt_lw_scheme) radiation_lw_select: select case (trim(radt_lw_scheme)) - case ("rrtmg_lw") call rrtmg_initlw_forMPAS(dminfo) @@ -801,7 +796,6 @@ subroutine init_radiation_lw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta call camradinit(dminfo,mesh,atm_input,diag,diag_physics,state,time_lev) case default - end select radiation_lw_select end subroutine init_radiation_lw @@ -845,12 +839,11 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, !call to longwave radiation scheme: radiation_lw_select: select case (trim(radt_lw_scheme)) - case ("rrtmg_lw") o3input = 0 if(config_o3climatology) o3input = 2 - call mpas_timer_start('RRTMG_lw') + call mpas_timer_start('rrtmg_lwrad') call rrtmg_lwrad( & p3d = pres_hyd_p , p8w = pres2_hyd_p , pi3d = pi_p , & t3d = t_p , t8w = t2_p , dz8w = dz_p , & @@ -872,7 +865,7 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, 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('RRTMG_lw') + call mpas_timer_stop('rrtmg_lwrad') case ("cam_lw") xtime_m = xtime_s/60. @@ -912,10 +905,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 , & @@ -940,7 +932,6 @@ subroutine driver_radiation_lw(xtime_s,configs,mesh,state,time_lev,diag_physics, call mpas_timer_stop('CAMRAD_lw') case default - end select radiation_lw_select !copy local arrays to MPAS grid: 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 35f5a42c1c..bc2be079ef 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_radiation_sw.F @@ -9,7 +9,7 @@ module mpas_atmphys_driver_radiation_sw 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_manager, only: gmt,curr_julday,julday,year @@ -18,6 +18,8 @@ module mpas_atmphys_driver_radiation_sw use mpas_atmphys_vars !wrf physics: + use module_mp_thompson_aerosols + use module_ra_rrtmg_sw_aerosols use module_ra_cam use module_ra_rrtmg_sw @@ -82,7 +84,19 @@ module mpas_atmphys_driver_radiation_sw ! Laura D. Fowler (laura@ucar.edu) / 2017-02-10. ! * since we removed the local variable radt_sw_scheme from mpas_atmphys_vars.F, now defines radt_sw_scheme ! as a pointer to config_radt_sw_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! 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. +! * in subroutine radiation_sw_from_MPAS, added the calculation of the optical properties of "water-friendly" and +! "ice-friendly" aerosols from the Thompson cloud microphysics scheme for use in the RRTMG short-wave radiation +! code. +! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. +! * in subroutine driver_radiation_sw, modified the argument list in the call to subroutine rrtmg_sw to include +! the optical properties of "water-friendly" and "ice-friendly" aerosols from the Thompson cloud microphysics +! scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. contains @@ -97,10 +111,12 @@ subroutine allocate_radiation_sw(configs,xtime_s) real(kind=RKIND),intent(in):: xtime_s !local pointers: - character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: mp_scheme, & + radt_sw_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme' ,mp_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) if(.not.allocated(f_ice) ) allocate(f_ice(ims:ime,kms:kme,jms:jme) ) @@ -130,7 +146,6 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(rthratensw_p) ) allocate(rthratensw_p(ims:ime,kms:kme,jms:jme) ) radiation_sw_select: select case (trim(radt_sw_scheme)) - case("rrtmg_sw") if(.not.allocated(recloud_p) ) allocate(recloud_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(reice_p) ) allocate(reice_p(ims:ime,kms:kme,jms:jme) ) @@ -145,6 +160,10 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(swnirdir_p) ) allocate(swnirdir_p(ims:ime,jms:jme) ) if(.not.allocated(swnirdif_p) ) allocate(swnirdif_p(ims:ime,jms:jme) ) + if(.not.allocated(swddir_p) ) allocate(swddir_p(ims:ime,jms:jme) ) + if(.not.allocated(swddni_p) ) allocate(swddni_p(ims:ime,jms:jme) ) + if(.not.allocated(swddif_p) ) allocate(swddif_p(ims:ime,jms:jme) ) + if(.not.allocated(swdnflx_p) ) allocate(swdnflx_p(ims:ime,kms:kme+1,jms:jme) ) if(.not.allocated(swdnflxc_p) ) allocate(swdnflxc_p(ims:ime,kms:kme+1,jms:jme) ) if(.not.allocated(swupflx_p) ) allocate(swupflx_p(ims:ime,kms:kme+1,jms:jme) ) @@ -153,6 +172,20 @@ subroutine allocate_radiation_sw(configs,xtime_s) if(.not.allocated(pin_p) ) allocate(pin_p(num_oznlevels) ) if(.not.allocated(o3clim_p) ) allocate(o3clim_p(ims:ime,1:num_oznlevels,jms:jme)) + if(.not.allocated(tauaer_p) ) allocate(tauaer_p(ims:ime,kms:kme,jms:jme,nbndsw) ) + if(.not.allocated(ssaaer_p) ) allocate(ssaaer_p(ims:ime,kms:kme,jms:jme,nbndsw) ) + if(.not.allocated(asyaer_p) ) allocate(asyaer_p(ims:ime,kms:kme,jms:jme,nbndsw) ) + + aerosol_select: select case(mp_scheme) + case("mp_thompson_aerosols") + if(.not.allocated(ht_p) ) allocate(ht_p(ims:ime,jms:jme) ) + if(.not.allocated(taer_type_p)) allocate(taer_type_p(ims:ime,jms:jme)) + if(.not.allocated(taod5502d_p)) allocate(taod5502d_p(ims:ime,jms:jme)) + if(.not.allocated(taod5503d_p)) allocate(taod5503d_p(ims:ime,kms:kme,jms:jme)) + + case default + end select aerosol_select + case("cam_sw") if(.not.allocated(glw_p) ) allocate(glw_p(ims:ime,jms:jme) ) if(.not.allocated(lwcf_p) ) allocate(lwcf_p(ims:ime,jms:jme) ) @@ -209,10 +242,12 @@ subroutine deallocate_radiation_sw(configs) type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: radt_sw_scheme + character(len=StrKIND),pointer:: mp_scheme, & + radt_sw_scheme !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_scheme' ,mp_scheme ) call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme) if(allocated(f_ice) ) deallocate(f_ice ) @@ -239,7 +274,6 @@ subroutine deallocate_radiation_sw(configs) if(allocated(rthratensw_p) ) deallocate(rthratensw_p ) radiation_sw_select: select case (trim(radt_sw_scheme)) - case("rrtmg_sw") if(allocated(recloud_p) ) deallocate(recloud_p ) if(allocated(reice_p) ) deallocate(reice_p ) @@ -249,6 +283,14 @@ subroutine deallocate_radiation_sw(configs) if(allocated(alswvisdif_p) ) deallocate(alswvisdif_p ) if(allocated(alswnirdir_p) ) deallocate(alswnirdir_p ) if(allocated(alswnirdif_p) ) deallocate(alswnirdif_p ) + if(allocated(swvisdir_p) ) deallocate(swvisdir_p ) + if(allocated(swvisdif_p) ) deallocate(swvisdif_p ) + if(allocated(swnirdir_p) ) deallocate(swnirdir_p ) + if(allocated(swnirdif_p) ) deallocate(swnirdif_p ) + + if(allocated(swddir_p) ) deallocate(swddir_p ) + if(allocated(swddni_p) ) deallocate(swddni_p ) + if(allocated(swddif_p) ) deallocate(swddif_p ) if(allocated(swdnflx_p) ) deallocate(swdnflx_p ) if(allocated(swdnflxc_p) ) deallocate(swdnflxc_p ) @@ -258,6 +300,20 @@ subroutine deallocate_radiation_sw(configs) if(allocated(pin_p) ) deallocate(pin_p ) if(allocated(o3clim_p) ) deallocate(o3clim_p ) + if(allocated(tauaer_p) ) deallocate(tauaer_p ) + if(allocated(ssaaer_p) ) deallocate(ssaaer_p ) + if(allocated(asyaer_p) ) deallocate(asyaer_p ) + + aerosol_select: select case(mp_scheme) + case("mp_thompson","mp_thompson_aerosols") + if(allocated(ht_p) ) deallocate(ht_p ) + if(allocated(taer_type_p)) deallocate(taer_type_p) + if(allocated(taod5502d_p)) deallocate(taod5502d_p) + if(allocated(taod5503d_p)) deallocate(taod5503d_p) + + case default + end select aerosol_select + case("cam_sw") if(allocated(pin_p) ) deallocate(pin_p ) if(allocated(m_hybi_p) ) deallocate(m_hybi_p ) @@ -318,24 +374,27 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i !local pointers: logical,pointer:: config_o3climatology + logical,pointer:: config_microp_re character(len=StrKIND),pointer:: radt_sw_scheme character(len=StrKIND),pointer:: microp_scheme - logical,pointer:: config_microp_re real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: skintemp,snow,xice,xland real(kind=RKIND),dimension(:),pointer :: m_ps,pin real(kind=RKIND),dimension(:),pointer :: sfc_albedo,sfc_emiss + real(kind=RKIND),dimension(:),pointer :: taod5502d + real(kind=RKIND),dimension(:,:),pointer :: zgrid real(kind=RKIND),dimension(:,:),pointer :: cldfrac,m_hybi,o3clim real(kind=RKIND),dimension(:,:),pointer :: re_cloud,re_ice,re_snow + real(kind=RKIND),dimension(:,:),pointer :: taod5503d real(kind=RKIND),dimension(:,:,:),pointer:: aerosols,ozmixm !----------------------------------------------------------------------------------------------------------------- + call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_config(configs,'config_o3climatology' ,config_o3climatology) call mpas_pool_get_config(configs,'config_radt_sw_scheme',radt_sw_scheme ) call mpas_pool_get_config(configs,'config_microp_scheme' ,microp_scheme ) - call mpas_pool_get_config(configs,'config_microp_re' ,config_microp_re ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -400,6 +459,9 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i swupbc_p(i,j) = 0.0_RKIND swupt_p(i,j) = 0.0_RKIND swuptc_p(i,j) = 0.0_RKIND + swddir_p(i,j) = 0.0_RKIND + swddni_p(i,j) = 0.0_RKIND + swddif_p(i,j) = 0.0_RKIND enddo do k = kts,kte @@ -409,12 +471,24 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo enddo + aer_opt = 0 + do n = 1,nbndsw + do j = jts,jte + do k = kts,kte + do i = its,ite + tauaer_p(i,k,j,n) = 0._RKIND + ssaaer_p(i,k,j,n) = 1._RKIND + asyaer_p(i,k,j,n) = 0._RKIND + enddo + enddo + enddo + enddo + radiation_sw_select: select case (trim(radt_sw_scheme)) case("rrtmg_sw") - microp_select: select case(microp_scheme) - case("mp_thompson","mp_wsm6") + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") if(config_microp_re) then call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) @@ -448,6 +522,63 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i case default end select microp_select + aerosol_select: select case(microp_scheme) + case("mp_thompson_aerosols") + call mpas_pool_get_array(mesh,'zgrid',zgrid) + call mpas_pool_get_array(diag_physics,'taod5502d',taod5502d) + call mpas_pool_get_array(diag_physics,'taod5503d',taod5503d) + + aer_opt = 3 + do j = jts,jte + do i = its,ite + ht_p(i,j) = zgrid(1,i) + if(xland_p(i,j)==1._RKIND) then + taer_type_p(i,j) = 1 + elseif(xland_p(i,j)==2._RKIND) then + taer_type_p(i,j) = 3 + endif + enddo + enddo + + !--- calculation of the 550 nm optical depth of the water- and ice-friendly aerosols: + call gt_aod( & + p_phy = pres_hyd_p , dz8w = dz_p , t_phy = t_p , qvapor = qv_p , & + nwfa = nwfa_p , nifa = nifa_p , taod5503d = taod5503d_p , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + + do j = jts,jte + do i = its,ite + taod5502d_p(i,j) = 0._RKIND + do k = kts,kte + taod5502d_p(i,j) = taod5502d_p(i,j) + taod5503d_p(i,k,j) + taod5503d(k,i) = taod5503d_p(i,k,j) + enddo + taod5502d(i) = taod5502d_p(i,j) + enddo + enddo + + !--- calculation of the spectral optical depth, single-scattering albedo, and asymmetry factor + !as a function of the 550 nm optical depth of the water- and ice-friendly aerosols: + call calc_aerosol_rrtmg_sw( & + ht = ht_p , dz8w = dz_p , & + p = pres_hyd_p , t3d = t_p , & + qv3d = qv_p , tauaer = tauaer_p , & + ssaaer = ssaaer_p , asyaer = asyaer_p , & + aod5502d = taod5502d_p , aod5503d = taod5503d_p , & + aer_type = taer_type_p , & + aer_aod550_opt = taer_aod550_opt , aer_angexp_opt = taer_angexp_opt , & + aer_ssa_opt = taer_ssa_opt , aer_asy_opt = taer_asy_opt , & + aer_aod550_val = aer_aod550_val , aer_angexp_val = aer_angexp_val , & + aer_ssa_val = aer_ssa_val , aer_asy_val = aer_asy_val , & + ims = ims , ime = ime , jms = jms , jme = jme , kms = kms , kme = kme , & + its = its , ite = ite , jts = jts , jte = jte , kts = kts , kte = kte & + ) + + case default + end select aerosol_select + do j = jts,jte do k = kts,kte+2 do i = its,ite @@ -569,7 +700,6 @@ subroutine radiation_sw_from_MPAS(configs,mesh,state,time_lev,diag_physics,atm_i enddo case default - end select radiation_sw_select end subroutine radiation_sw_from_MPAS @@ -589,10 +719,13 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) !local pointers: real(kind=RKIND),dimension(:),pointer :: coszr,gsw,swcf,swdnb,swdnbc,swdnt,swdntc, & - swupb,swupbc,swupt,swuptc + swupb,swupbc,swupt,swuptc,swddir,swddni, & + swddif real(kind=RKIND),dimension(:,:),pointer:: rthratensw !----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine radiation_sw_to_MPAS:') call mpas_pool_get_array(diag_physics,'coszr' ,coszr ) call mpas_pool_get_array(diag_physics,'gsw' ,gsw ) @@ -602,9 +735,12 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) call mpas_pool_get_array(diag_physics,'swdnt' ,swdnt ) call mpas_pool_get_array(diag_physics,'swdntc' ,swdntc ) call mpas_pool_get_array(diag_physics,'swupb' ,swupb ) - call mpas_pool_get_array(diag_physics,'swupbc' , swupbc ) + call mpas_pool_get_array(diag_physics,'swupbc' ,swupbc ) call mpas_pool_get_array(diag_physics,'swupt' ,swupt ) call mpas_pool_get_array(diag_physics,'swuptc' ,swuptc ) + call mpas_pool_get_array(diag_physics,'swddir' ,swddir ) + call mpas_pool_get_array(diag_physics,'swddni' ,swddni ) + call mpas_pool_get_array(diag_physics,'swddif' ,swddif ) call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) do j = jts,jte @@ -621,6 +757,9 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) swupbc(i) = swupbc_p(i,j) swupt(i) = swupt_p(i,j) swuptc(i) = swuptc_p(i,j) + swddir(i) = swddir_p(i,j) + swddni(i) = swddni_p(i,j) + swddif(i) = swddif_p(i,j) enddo do k = kts,kte @@ -631,6 +770,9 @@ subroutine radiation_sw_to_MPAS(diag_physics,tend_physics,its,ite) enddo +!call mpas_log_write('--- enter subroutine radiation_sw_to_MPAS:') +!call mpas_log_write(' ') + end subroutine radiation_sw_to_MPAS !================================================================================================================= @@ -659,7 +801,6 @@ subroutine init_radiation_sw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) - case ("rrtmg_sw") call rrtmg_initsw_forMPAS(dminfo) @@ -667,7 +808,6 @@ subroutine init_radiation_sw(dminfo,configs,mesh,atm_input,diag,diag_physics,sta call camradinit(dminfo,mesh,atm_input,diag,diag_physics,state,time_lev) case default - end select radiation_sw_select end subroutine init_radiation_sw @@ -735,12 +875,11 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic !call to shortwave radiation scheme: radiation_sw_select: select case (trim(radt_sw_scheme)) - case ("rrtmg_sw") o3input = 0 if(config_o3climatology) o3input = 2 - call mpas_timer_start('RRTMG_sw') + call mpas_timer_start('rrtmg_swrad') call rrtmg_swrad( & p3d = pres_hyd_p , p8w = pres2_hyd_p , pi3d = pi_p , & t3d = t_p , t8w = t2_p , dz8w = dz_p , & @@ -757,17 +896,20 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_physic o3clim = o3clim_p , gsw = gsw_p , swcf = swcf_p , & rthratensw = rthratensw_p , has_reqc = has_reqc , has_reqi = has_reqi , & has_reqs = has_reqs , re_cloud = recloud_p , re_ice = reice_p , & - re_snow = resnow_p , swupt = swupt_p , swuptc = swuptc_p , & - swdnt = swdnt_p , swdntc = swdntc_p , swupb = swupb_p , & - swupbc = swupbc_p , swdnb = swdnb_p , swdnbc = swdnbc_p , & + re_snow = resnow_p , aer_opt = aer_opt , tauaer3d = tauaer_p , & + ssaaer3d = ssaaer_p , asyaer3d = asyaer_p , swupt = swupt_p , & + swuptc = swuptc_p , swdnt = swdnt_p , swdntc = swdntc_p , & + swupb = swupb_p , swupbc = swupbc_p , swdnb = swdnb_p , & + swdnbc = swdnbc_p , swddir = swddir_p , swddni = swddni_p , & + swddif = swddif_p , & 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('RRTMG_sw') + call mpas_timer_stop('rrtmg_swrad') case ("cam_sw") - call mpas_timer_start('CAMRAD_sw') + call mpas_timer_start('camrad_sw') call camrad( dolw = .false. , dosw = .true. , & p_phy = pres_hyd_p , p8w = pres2_hyd_p , & pi_phy = pi_p , t_phy = t_p , & @@ -791,10 +933,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 , & @@ -816,10 +957,9 @@ subroutine driver_radiation_sw(itimestep,configs,mesh,state,time_lev,diag_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('CAMRAD_sw') + call mpas_timer_stop('camrad_sw') case default - end select radiation_sw_select !copy local arrays to MPAS grid: 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 afe42154d8..afde4fa523 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F +++ b/src/core_atmosphere/physics/mpas_atmphys_driver_sfclayer.F @@ -14,9 +14,11 @@ 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 private @@ -78,7 +80,14 @@ module mpas_atmphys_driver_sfclayer ! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. ! * since we removed the local variable sfclayer_scheme from mpas_atmphys_vars.F, now defines sfclayer_scheme ! as a pointer to config_sfclayer_scheme. -! Laura D. Fowler (laura@ucar.edu) / 2917-02-16. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * in subroutine driver_sfclayer, replaced the call to sfclay with a call to sfclayrev to use the revised +! version of the MONIN-OBUKHOV surface layer scheme. +! 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 @@ -184,7 +193,7 @@ subroutine allocate_sfclayer(configs) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") if(.not.allocated(fh_p)) allocate(fh_p(ims:ime,jms:jme)) if(.not.allocated(fm_p)) allocate(fm_p(ims:ime,jms:jme)) if(config_frac_seaice) then @@ -192,6 +201,17 @@ subroutine allocate_sfclayer(configs) if(.not.allocated(fm_sea)) allocate(fm_sea(ims:ime,jms:jme)) endif + sfclayer2_select: select case(sfclayer_scheme) + + case("sf_monin_obukhov_rev") + if(.not.allocated(waterdepth_p)) allocate(waterdepth_p(ims:ime,jms:jme)) + if(.not.allocated(lakedepth_p) ) allocate(lakedepth_p(ims:ime,jms:jme) ) + if(.not.allocated(lakemask_p) ) allocate(lakemask_p(ims:ime,jms:jme) ) + + case default + + end select sfclayer2_select + case("sf_mynn") if(.not.allocated(snowh_p)) allocate(snowh_p(ims:ime,jms:jme)) if(.not.allocated(ch_p) ) allocate(ch_p(ims:ime,jms:jme) ) @@ -200,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 @@ -301,7 +315,7 @@ subroutine deallocate_sfclayer(configs) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") if(allocated(fh_p)) deallocate(fh_p) if(allocated(fm_p)) deallocate(fm_p) if(config_frac_seaice) then @@ -309,6 +323,17 @@ subroutine deallocate_sfclayer(configs) if(allocated(fm_sea)) deallocate(fm_sea) endif + sfclayer2_select: select case(sfclayer_scheme) + + case("sf_monin_obukhov_rev") + if(allocated(waterdepth_p)) deallocate(waterdepth_p) + if(allocated(lakedepth_p) ) deallocate(lakedepth_p ) + if(allocated(lakemask_p) ) deallocate(lakemask_p ) + + case default + + end select sfclayer2_select + case("sf_mynn") if(allocated(snowh_p)) deallocate(snowh_p) if(allocated(ch_p) ) deallocate(ch_p ) @@ -317,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 @@ -361,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 !----------------------------------------------------------------------------------------------------------------- @@ -516,7 +534,7 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") call mpas_pool_get_array(diag_physics,'fh',fh) call mpas_pool_get_array(diag_physics,'fm',fm) @@ -531,17 +549,28 @@ subroutine sfclayer_from_MPAS(configs,mesh,diag_physics,sfc_input,its,ite) enddo enddo + sfclayer2_select: select case(sfclayer_scheme) + + case("sf_monin_obukhov_rev") + + do j = jts,jte + do i = its,ite + waterdepth_p(i,j) = 0._RKIND + lakedepth_p(i,j) = 0._RKIND + lakemask_p(i,j) = 0._RKIND + enddo + enddo + + case default + + end select sfclayer2_select + 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 @@ -556,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 @@ -606,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 !----------------------------------------------------------------------------------------------------------------- @@ -733,7 +748,7 @@ subroutine sfclayer_to_MPAS(configs,sfc_input,diag_physics,its,ite) sfclayer_select: select case (trim(sfclayer_scheme)) - case("sf_monin_obukhov") + case("sf_monin_obukhov","sf_monin_obukhov_rev") call mpas_pool_get_array(diag_physics,'fh',fh) call mpas_pool_get_array(diag_physics,'fm',fm) @@ -791,8 +806,16 @@ subroutine init_sfclayer(configs) logical, parameter:: allowed_to_read = .false. !actually not used in subroutine sfclayinit. character(len=StrKIND),pointer:: sfclayer_scheme +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme) sfclayer_select: select case (trim(sfclayer_scheme)) @@ -800,8 +823,11 @@ subroutine init_sfclayer(configs) case("sf_monin_obukhov") call sfclayinit(allowed_to_read) + case("sf_monin_obukhov_rev") + 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 @@ -833,10 +859,18 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite integer:: initflag real(kind=RKIND):: dx +!CCPP-compliant flags: + character(len=StrKIND):: errmsg + integer:: errflg + !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter subroutine driver_sfclayer:') +!initialization of CCPP-compliant flags: + errmsg = ' ' + errflg = 0 + call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice' ,config_frac_seaice) call mpas_pool_get_config(configs,'config_sfclayer_scheme',sfclayer_scheme ) @@ -854,12 +888,12 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite sfclayer_select: select case (trim(sfclayer_scheme)) case("sf_monin_obukhov") - call mpas_timer_start('Monin-Obukhov') + call mpas_timer_start('sf_monin_obukhov') call sfclay( & p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & u3d = u_p , v3d = v_p , qv3d = qv_p , & dz8w = dz_p , cp = cp , g = gravity , & - rovcp = rcp , R = R_d , xlv = xlv , & + 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 , & @@ -871,14 +905,13 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite rmol = rmol_p , u10 = u10_p , v10 = v10_p , & th2 = th2m_p , t2 = t2m_p , q2 = q2_p , & gz1oz0 = gz1oz0_p , wspd = wspd_p , br = br_p , & - isfflx = isfflx , dx = dx , svp1 = svp1 , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & - dxCell = dx_p , ustm = ustm_p , ck = ck_p , & - cka = cka_p , cd = cd_p , cda = cda_p , & - isftcflx = isftcflx , iz0tlnd = iz0tlnd , & - scm_force_flux = scm_force_flux , & + ustm = ustm_p , ck = ck_p , cka = cka_p , & + cd = cd_p , cda = cda_p , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & 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 & @@ -901,87 +934,147 @@ subroutine driver_sfclayer(itimestep,configs,mesh,diag_physics,sfc_input,its,ite rmol = rmol_sea , u10 = u10_sea , v10 = v10_sea , & th2 = th2m_sea , t2 = t2m_sea , q2 = q2_sea , & gz1oz0 = gz1oz0_sea , wspd = wspd_sea , br = br_sea , & - isfflx = isfflx , dx = dx , svp1 = svp1 , & + isfflx = isfflx , dx = dx_p , svp1 = svp1 , & svp2 = svp2 , svp3 = svp3 , svpt0 = svpt0 , & ep1 = ep_1 , ep2 = ep_2 , karman = karman , & eomeg = eomeg , stbolt = stbolt , P1000mb = P0 , & - dxCell = dx_p , ustm = ustm_sea , ck = ck_sea , & - cka = cka_sea , cd = cd_sea , cda = cda_sea , & - isftcflx = isftcflx , iz0tlnd = iz0tlnd , & - scm_force_flux = scm_force_flux , & + ustm = ustm_sea , ck = ck_sea , cka = cka_sea , & + cd = cd_sea , cda = cda_sea , isftcflx = isftcflx , & + iz0tlnd = iz0tlnd , scm_force_flux = scm_force_flux , & 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('Monin-Obukhov') + call mpas_timer_stop('sf_monin_obukhov') + + case("sf_monin_obukhov_rev") + call mpas_timer_start('sf_monin_obukhov_rev') + call sfclayrev( & + p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & + u3d = u_p , v3d = v_p , qv3d = qv_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 , fm = fm_p , fh = fh_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 , & + 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 , & + p1000mb = P0 , lakemask = lakemask_p , ustm = ustm_p , & + ck = ck_p , cka = cka_p , cd = cd_p , & + cda = cda_p , isftcflx = isftcflx , iz0tlnd = iz0tlnd , & + shalwater_z0 = shalwater_flag , water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & + 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 sfclayrev( & + p3d = pres_hyd_p , psfc = psfc_p , t3d = t_p , & + u3d = u_p , v3d = v_p , qv3d = qv_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 , fm = fm_sea , fh = fh_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 , & + 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 , & + p1000mb = P0 , lakemask = lakemask_p , ustm = ustm_sea , & + ck = ck_sea , cka = cka_sea , cd = cd_sea , & + cda = cda_sea , isftcflx = isftcflx , iz0tlnd = iz0tlnd , & + shalwater_z0 = shalwater_flag , water_depth = waterdepth_p , scm_force_flux = scm_force_flux , & + 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('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_finalize.F b/src/core_atmosphere/physics/mpas_atmphys_finalize.F index 8ad9248196..903042246e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_finalize.F +++ b/src/core_atmosphere/physics/mpas_atmphys_finalize.F @@ -9,6 +9,7 @@ module mpas_atmphys_finalize use mpas_pool_routines + use mpas_atmphys_lsm_noahmpfinalize,only: sf_noahmp_deallocate use module_mp_thompson implicit none @@ -37,14 +38,21 @@ subroutine atmphys_finalize(configs) type(mpas_pool_type),intent(in):: configs !local variables and pointers: - character(len=StrKIND),pointer:: config_microp_scheme + character(len=StrKIND),pointer:: config_lsm_scheme, & + config_microp_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) - if(trim(config_microp_scheme) == 'mp_thompson') & + if(trim(config_lsm_scheme) == 'sf_noahmp') & + call sf_noahmp_deallocate + + if(trim(config_microp_scheme) == 'mp_thompson' .or. & + trim(config_microp_scheme) == 'mp_thompson_aerosols') then call mp_thompson_deallocate + endif end subroutine atmphys_finalize diff --git a/src/core_atmosphere/physics/mpas_atmphys_init.F b/src/core_atmosphere/physics/mpas_atmphys_init.F index 92112da785..ce767fb6b3 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init.F @@ -11,15 +11,18 @@ module mpas_atmphys_init use mpas_pool_routines use mpas_timekeeping - use mpas_atmphys_driver_convection, only: init_convection + 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_radiation_lw, only: init_radiation_lw - use mpas_atmphys_driver_radiation_sw, only: init_radiation_sw - use mpas_atmphys_driver_sfclayer + use mpas_atmphys_driver_microphysics,only: init_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,only: init_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 + use mpas_atmphys_lsm_noahmpinit,only: init_lsm_noahmp implicit none private @@ -64,14 +67,18 @@ 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. +! * added call to subroutine init_lsm_noahmp to initialize the Noah-MP land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2024-03-11. contains !================================================================================================================= - subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_physics, & - atm_input,sfc_input) + subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_physics,diag_physics_noahmp, & + atm_input,sfc_input,output_noahmp) !================================================================================================================= !input arguments: @@ -87,61 +94,62 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp type(mpas_pool_type),intent(inout):: atm_input type(mpas_pool_type),intent(inout):: sfc_input + type(mpas_pool_type),intent(inout):: output_noahmp !local pointers: - logical,pointer:: config_do_restart, & - config_o3climatology + logical,pointer:: config_do_restart, & + config_o3climatology, & + config_oml1d 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 integer,pointer:: nCellsSolve,nLags - integer,dimension(:),pointer :: i_rainc,i_rainnc - integer,dimension(:),pointer :: i_acswdnb,i_acswdnbc,i_acswdnt,i_acswdntc, & - i_acswupb,i_acswupbc,i_acswupt,i_acswuptc, & - i_aclwdnb,i_aclwdnbc,i_aclwdnt,i_aclwdntc, & - i_aclwupb,i_aclwupbc,i_aclwupt,i_aclwuptc - - real(kind=RKIND),dimension(:),pointer :: acswdnb,acswdnbc,acswdnt,acswdntc, & - acswupb,acswupbc,acswupt,acswuptc, & - aclwdnb,aclwdnbc,aclwdnt,aclwdntc, & - aclwupb,aclwupbc,aclwupt,aclwuptc - real(kind=RKIND),dimension(:),pointer :: nsteps_accum,ndays_accum,tday_accum, & - tyear_accum,tyear_mean - real(kind=RKIND),dimension(:),pointer :: sst,sstsk,tmn,xice,xicem + integer,dimension(:),pointer:: i_rainc,i_rainnc + integer,dimension(:),pointer:: i_acswdnb,i_acswdnbc,i_acswdnt,i_acswdntc, & + i_acswupb,i_acswupbc,i_acswupt,i_acswuptc, & + i_aclwdnb,i_aclwdnbc,i_aclwdnt,i_aclwdntc, & + i_aclwupb,i_aclwupbc,i_aclwupt,i_aclwuptc + + real(kind=RKIND),dimension(:),pointer:: acswdnb,acswdnbc,acswdnt,acswdntc, & + acswupb,acswupbc,acswupt,acswuptc, & + aclwdnb,aclwdnbc,aclwdnt,aclwdntc, & + aclwupb,aclwupbc,aclwupt,aclwuptc + real(kind=RKIND),dimension(:),pointer:: nsteps_accum,ndays_accum,tday_accum, & + tyear_accum,tyear_mean + real(kind=RKIND),dimension(:),pointer:: sst,sstsk,tmn,xice,xicem real(kind=RKIND),dimension(:,:),pointer:: tlag - real(kind=RKIND),dimension(:),pointer :: t_oml, t_oml_initial, t_oml_200m_initial - real(kind=RKIND),dimension(:),pointer :: h_oml, h_oml_initial, hu_oml, hv_oml - real(kind=RKIND), pointer :: config_oml_hml0 - integer,pointer:: nCells - logical,pointer:: config_oml1d - - + real(kind=RKIND),pointer:: config_oml_hml0 + real(kind=RKIND),dimension(:),pointer:: t_oml,t_oml_initial,t_oml_200m_initial + real(kind=RKIND),dimension(:),pointer:: h_oml,h_oml_initial,hu_oml,hv_oml !local variables and arrays: type(MPAS_Time_Type):: currTime logical:: init_done integer:: ierr,julday - integer:: iCell,iLag,iEdge,nEdges_m + integer:: iCell,iLag !----------------------------------------------------------------------------------------------------------------- -! call mpas_log_write('') -! call mpas_log_write('--- enter subroutine physics_init:') +!call mpas_log_write('') +!call mpas_log_write('--- enter subroutine physics_init:') 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 ) @@ -205,7 +213,6 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ call mpas_pool_get_array(diag_physics,'hv_oml' ,hv_oml) call mpas_pool_get_config(configs,'config_oml1d' ,config_oml1d ) call mpas_pool_get_config(configs,'config_oml_hml0' ,config_oml_hml0 ) - call mpas_pool_get_dimension(mesh,'nCells',nCells) currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr) call mpas_get_time(curr_time=currTime,DoY=julday,ierr=ierr) @@ -214,6 +221,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: @@ -274,7 +285,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !initialization of xicem: if(.not.config_do_restart) then -! call mpas_log_write('--- initialization of xicem:') +! call mpas_log_write('--- initialization of xicem:') do iCell = 1, nCellsSolve xicem(iCell) = xice(iCell) enddo @@ -284,47 +295,47 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !sea-surface temperature is applied. This avoids having the array sstsk equal to !zero over land: if(.not. config_do_restart) then -! call mpas_log_write('--- initialization of sstsk:') +! call mpas_log_write('--- initialization of sstsk:') do iCell = 1, nCellsSolve sstsk(iCell) = sst(iCell) enddo endif -! initialized the 1D ocean mixed-layer model (code from wrf module_sf_oml) - if (config_oml1d) then - if (.not. config_do_restart) then - call mpas_log_write('--- initialization of 1D ocean mixed layer model ') - do iCell = 1, nCellsSolve - t_oml(iCell) = sst(iCell) - t_oml_initial(iCell) = sst(iCell) - end do - if (config_oml_hml0 .gt. 0) then - do iCell = 1, nCellsSolve - h_oml(iCell) = config_oml_hml0 - h_oml_initial(iCell) = config_oml_hml0 - hu_oml(iCell) = 0. - hv_oml(iCell) = 0. - t_oml_200m_initial(iCell) = sst(iCell) - 5. - end do - else if (config_oml_hml0 .eq. 0) then -! initializing with climatological mixed layer depth only - do iCell = 1, nCellsSolve - h_oml(iCell) = h_oml_initial(iCell) - hu_oml(iCell) = 0. - hv_oml(iCell) = 0. - t_oml_200m_initial(iCell) = sst(iCell) - 5. - end do - else - do iCell = 1, nCellsSolve - h_oml(iCell) = h_oml_initial(iCell) - ! WRF COMMENT: - ! fill in near coast area with SST: 200 K was set as missing value in ocean pre-processing code - if( (t_oml_200m_initial(iCell) > 200.) .and. (t_oml_200m_initial(iCell) <= 200.) ) & - t_oml_200m_initial(iCell) = sst(iCell) - end do - end if - end if - end if +!initialized the 1D ocean mixed-layer model (code from wrf module_sf_oml): + if(config_oml1d) then + if(.not. config_do_restart) then + call mpas_log_write('--- initialization of 1D ocean mixed layer model ') + do iCell = 1, nCellsSolve + t_oml(iCell) = sst(iCell) + t_oml_initial(iCell) = sst(iCell) + enddo + if(config_oml_hml0 .gt. 0) then + do iCell = 1, nCellsSolve + h_oml(iCell) = config_oml_hml0 + h_oml_initial(iCell) = config_oml_hml0 + hu_oml(iCell) = 0. + hv_oml(iCell) = 0. + t_oml_200m_initial(iCell) = sst(iCell) - 5. + enddo + elseif(config_oml_hml0 .eq. 0) then +! initializing with climatological mixed layer depth only: + do iCell = 1, nCellsSolve + h_oml(iCell) = h_oml_initial(iCell) + hu_oml(iCell) = 0. + hv_oml(iCell) = 0. + t_oml_200m_initial(iCell) = sst(iCell) - 5. + enddo + else + do iCell = 1, nCellsSolve + h_oml(iCell) = h_oml_initial(iCell) + ! WRF COMMENT: + ! fill in near coast area with SST: 200 K was set as missing value in ocean pre-processing code + if( (t_oml_200m_initial(iCell) > 200.) .and. (t_oml_200m_initial(iCell) <= 200.) ) & + t_oml_200m_initial(iCell) = sst(iCell) + enddo + endif + endif + endif !initialization of temperatures needed for updating the deep soil temperature: if(.not. config_do_restart) then @@ -341,8 +352,7 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ endif !read the input files that contain the monthly-mean ozone climatology on fixed pressure levels: - if(config_o3climatology .and. (.not. config_do_restart)) & - call init_o3climatology(mesh,atm_input) + if(config_o3climatology) call init_o3climatology(mesh,atm_input) !initialization of global surface properties. set here for now, but may be moved when time !manager is implemented: @@ -354,16 +364,22 @@ subroutine physics_init(dminfo,clock,configs,mesh,diag,tend,state,time_lev,diag_ !initialization of cloud microphysics processes: if(config_microp_scheme .ne. 'off') & - call microphysics_init(dminfo,configs,mesh,sfc_input,diag_physics) + call init_microphysics(dminfo,configs,mesh,state,time_lev,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) !initialization of land-surface model: -!if(.not. config_do_restart) then -! if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) -!endif - if(config_lsm_scheme .ne. 'off') call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) + if(config_lsm_scheme .ne. 'off') then + if(config_lsm_scheme .eq. 'sf_noah') then + call init_lsm(dminfo,mesh,configs,diag_physics,sfc_input) + elseif(config_lsm_scheme .eq. 'sf_noahmp') then + call init_lsm_noahmp(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + endif + endif !initialization of shortwave radiation processes: init_done = .false. @@ -398,6 +414,60 @@ 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_nc,index_ni,index_nifa,index_nwfa + +!----------------------------------------------------------------------------------------------------------------- + +!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. + f_ni = .false. + f_nifa = .false. + f_nwfa = .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_nc' ,index_nc ) + call mpas_pool_get_dimension(state,'index_ni' ,index_ni ) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + if(index_nc .gt. -1) f_nc = .true. + if(index_ni .gt. -1) f_ni = .true. + if(index_nifa .gt. -1) f_nifa = .true. + if(index_nwfa .gt. -1) f_nwfa = .true. + + end subroutine init_physics_flags + !================================================================================================================= subroutine init_dirs_forphys(mesh) !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F index 99db47ced6..f2a75d6c90 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_init_microphysics.F @@ -5,20 +5,23 @@ ! 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 ! +#define DM_BCAST_MACRO(A) call mpas_dmpar_bcast_real4s(dminfo,size(A),A) !================================================================================================================= module mpas_atmphys_init_microphysics use mpas_dmpar use mpas_kind_types + use mpas_log use mpas_pool_routines use mpas_atmphys_utilities -!use module_mp_thompson, only: is_aerosol_aware,naCCN0,naCCN1,naIN0,naIN1,ntb_arc,ntb_arw,ntb_art,ntb_arr, & -! ntb_ark,tnccn_act + use module_mp_thompson, only: is_aerosol_aware,naCCN0,naCCN1,naIN0,naIN1,ntb_arc,ntb_arw,ntb_art,ntb_arr, & + ntb_ark,tnccn_act implicit none private - public:: init_thompson_clouddroplets_forMPAS + public:: init_thompson_clouddroplets_forMPAS, & + init_thompson_aerosols_forMPAS !MPAS main initialization of the Thompson parameterization of cloud microphysics with nucleation of cloud !droplets based on distributions of CCNs and INs (aerosol-aware parameterization). @@ -29,6 +32,15 @@ module mpas_atmphys_init_microphysics ! ---------------------------------------- ! * added "use mpas_dmpar" at the top of the module. ! Laura D. Fowler (laura@ucar.edu) / 2016-04-04. +! * modified the initialization of nifa and nwfa.If nifa and nwfa are already available in the initial conditions +! using the climatological GOCART data,do not recalculate nifa and nwfa using an exponential profile of CCN and +! IN as a function of height. +! Laura D. Fowler (laura@ucar.edu) / 2016-05-27. +! * modified the subroutine init_thompson_aerosols_forMPAS for exact restartibility when using the microphysics +! option "mp_thompson_aerosols". +! Laura D. Fowler (laura@ucar.edu) / 2018-02-23. +! * changed the definition of DM_BCAST_MACRO to compile table_ccnAct with the default DOUBLE PRECISION. +! Laura D. Fowler (laura@ucar.edu) / 2018-03-07. contains @@ -80,8 +92,225 @@ subroutine init_thompson_clouddroplets_forMPAS(mesh,sfc_input,diag_physics) end subroutine init_thompson_clouddroplets_forMPAS !================================================================================================================= - end module mpas_atmphys_init_microphysics + subroutine init_thompson_aerosols_forMPAS(do_restart,dminfo,mesh,state,time_lev,diag_physics) +!================================================================================================================= + +!input variables: + type(dm_info),intent(in):: dminfo + type(mpas_pool_type),intent(in):: mesh + logical,intent(in):: do_restart + integer,intent(in):: time_lev + +!inout variables: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: state + +!local variables and pointers: + integer,pointer:: nCellsSolve,nVertLevels + integer,pointer:: index_nifa,index_nwfa + + real(kind=RKIND),dimension(:),pointer :: areaCell + real(kind=RKIND),dimension(:),pointer :: nifa2d,nwfa2d + real(kind=RKIND),dimension(:,:),pointer :: zgrid,zz + real(kind=RKIND),dimension(:,:),pointer :: rho_zz,nifa,nwfa + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + character(len=StrKIND):: mess + + integer:: iCell, k + + real(kind=RKIND):: max_test + real(kind=RKIND):: airmass + real(kind=RKIND):: h_01 + real(kind=RKIND):: niIN3,niCCN3 + real(kind=RKIND):: nifa_max,nifa_min,global_nifa_max,global_nifa_min + real(kind=RKIND):: nwfa_max,nwfa_min,global_nwfa_max,global_nwfa_min + real(kind=RKIND),dimension(:,:),allocatable:: hgt + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_thompson_aerosols_forMPAS:') + + is_aerosol_aware = .true. + +!... read a static file containing CCN activation of aerosols. The data were created from a parcel model by +!... Feingold & Heymsfield with further changes by Eidhammer and Kriedenweis. + call table_ccnAct(dminfo) + call mpas_log_write('--- end read table_ccnAct:') + +!... if do_restart is true, then we do not need to check the initialization of nwfa, nifa, and nwfa2d. If false, +! then, we proceed with the initialization: + if(do_restart) return + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + + call mpas_pool_get_array(mesh,'areaCell',areaCell) + call mpas_pool_get_array(mesh,'zgrid' ,zgrid ) + call mpas_pool_get_array(mesh,'zz' ,zz ) + + call mpas_pool_get_array(diag_physics,'nifa2d',nifa2d) + call mpas_pool_get_array(diag_physics,'nwfa2d',nwfa2d) + + call mpas_pool_get_dimension(state,'index_nifa' ,index_nifa ) + call mpas_pool_get_dimension(state,'index_nwfa' ,index_nwfa ) + + call mpas_pool_get_array(state,'scalars',scalars,time_lev) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + call mpas_pool_get_array(state,'rho_zz',rho_zz,time_lev) + + if(.not.allocated(hgt)) allocate(hgt(1:nVertLevels,1:nCellsSolve)) + do iCell = 1, nCellsSolve + do k = 1, nVertLevels + hgt(k,iCell) = 0.5_RKIND * (zgrid(k,iCell)+zgrid(k+1,iCell)) + enddo + enddo + +!... initialize the distribution of hygroscopic ("water friendly") aerosols if not already initialized using +! GOCART data: + global_nwfa_min = 0._RKIND + global_nwfa_max = 0._RKIND + nwfa_min = minval(nwfa(:,1:nCellsSolve)) + nwfa_max = maxval(nwfa(:,1:nCellsSolve)) + call mpas_dmpar_min_real(dminfo,nwfa_min,global_nwfa_min) + call mpas_dmpar_max_real(dminfo,nwfa_max,global_nwfa_max) + call mpas_log_write('--- global_nwfa_min = $r',realArgs=(/global_nwfa_min/)) + call mpas_log_write('--- global_nwfa_max = $r',realArgs=(/global_nwfa_max/)) + + if(global_nwfa_min == 0._RKIND .and. global_nwfa_max == 0._RKIND) then + call mpas_log_write('--- initialize nwfa using an exponential distribution of CCN as a function of height.') + do iCell = 1, nCellsSolve + if(hgt(1,iCell).le.1000.0) then + h_01 = 0.8 + elseif(hgt(1,iCell).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(1,iCell)*0.001 - 1.0) + endif + niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01 + nwfa(1,iCell) = naCCN1+naCCN0*exp(-((hgt(2,iCell)-hgt(1,iCell))/1000.)*niCCN3) + do k = 2, nVertLevels + nwfa(k,iCell) = naCCN1+naCCN0*exp(-((hgt(k,iCell)-hgt(1,iCell))/1000.)*niCCN3) + enddo + enddo + else + call mpas_log_write('--- initialize nwfa using the climatological GOCART data.') + endif + +!... initialize the distribution of nonhygroscopic ("ice friendly") aerosols if not already initialized using +! GOCART data: + global_nifa_min = 0._RKIND + global_nifa_max = 0._RKIND + nifa_min = minval(nifa(:,1:nCellsSolve)) + nifa_max = maxval(nifa(:,1:nCellsSolve)) + call mpas_dmpar_min_real(dminfo,nifa_min,global_nifa_min) + call mpas_dmpar_max_real(dminfo,nifa_max,global_nifa_max) + call mpas_log_write('--- global_nifa_min = $r',realArgs=(/global_nifa_min/)) + call mpas_log_write('--- global_nifa_max = $r',realArgs=(/global_nifa_max/)) + + if(global_nifa_min == 0._RKIND .and. global_nifa_max == 0._RKIND) then + call mpas_log_write('--- initialize nifa using an exponential distribution of IN as a function of height.') + do iCell = 1, nCellsSolve + if(hgt(1,iCell).le.1000.0) then + h_01 = 0.8 + elseif(hgt(1,iCell).ge.2500.0) then + h_01 = 0.01 + else + h_01 = 0.8*cos(hgt(1,iCell)*0.001 - 1.0) + endif + niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01 + nifa(1,iCell) = naIN1+naIN0*exp(-((hgt(2,iCell)-hgt(1,iCell))/1000.)*niIN3) + do k = 2, nVertLevels + nifa(k,iCell) = naIN1+naIN0*exp(-((hgt(k,iCell)-hgt(1,iCell))/1000.)*niIN3) + enddo + enddo + else + call mpas_log_write('--- initialize nifa using the climatological GOCART data.') + endif + +!... scale the lowest level aerosol data into an emissions rate. This is very far from ideal, but +!... need higher emissions where larger amount of (climo) existing and lesser emissions where there +!... exists fewer to begin as a first-order simplistic approach. Later, proper connection to emission +!... inventory would be better, but, for now, scale like this: +!... where: Nwfa=50 per cc, emit 0.875E4 aerosols per second per grid box unit +!... that was tested as ~(20kmx20kmx50m = 2.E10 m**3). + + k = 1 + do iCell = 1, nCellsSolve + airmass = rho_zz(k,iCell)*zz(k,iCell) + airmass = airmass*(zgrid(k+1,iCell)-zgrid(k,iCell))*areaCell(iCell) ! (in kg) + nwfa2d(iCell) = nwfa(k,iCell)*0.000196*airmass*0.5e-10 + nifa2d(iCell) = 0._RKIND +! call mpas_log_write('$i $r $r $r',intArgs=(/iCell/),realArgs=(/airmass,nwfa2d(iCell),nifa2d(iCell)/)) + enddo + +!... deallocate local arrays: + if(allocated(hgt)) deallocate(hgt) + +!call mpas_log_write('--- end subroutine init_thompson_aerosols_forMPAS.') + + end subroutine init_thompson_aerosols_forMPAS + !================================================================================================================= + subroutine table_ccnAct(dminfo) +!================================================================================================================= + +!input variables: + type(dm_info),intent(in):: dminfo - - +!local variables: + logical:: opened + integer:: ccn_unit,i,istat + character(len=StrKIND):: errmess +!----------------------------------------------------------------------------------------------------------------- + + if(.not.allocated(tnccn_act)) allocate(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark)) + +!get a unit to open binary file: + istat = -999 + if(dminfo % my_proc_id == IO_NODE) then + do i = 10,99 + inquire(i,opened = opened,iostat=istat) + if(.not. opened ) then + ccn_unit = i + exit + endif + enddo + if(istat /= 0) & + call physics_error_fatal('mpas_atmphys_init_microphysics table_ccnAct: Can not '// & + 'find unused fortran unit to read in lookup table.' ) + endif + +!distribute unit to other processors: + call mpas_dmpar_bcast_int(dminfo,ccn_unit) + +!open binary file: + istat = -999 + if(dminfo % my_proc_id == IO_NODE) then + open(ccn_unit,file='CCN_ACTIVATE_DATA',form='UNFORMATTED',status='OLD',iostat=istat) + if(istat /= 0) then + write(errmess,'(A,I4)') 'mpas_atmphys_init_microphysics table_ccnAct:: '// & + 'error opening CCN_ACTIVATE_DATA on unit', ccn_unit + call physics_error_fatal(errmess) + endif + endif + +!read and broadcast data to all nodes: + istat = -999 + if(dminfo % my_proc_id == IO_NODE) then + read(ccn_unit,iostat=istat) tnccn_act + if(istat /= 0) then + write(errmess,'(A,I4)') 'mpas_atmphys_init_microphysics table_ccnAct:: '// & + 'error reading tnccn_act on unit', ccn_unit + call physics_error_fatal(errmess) + endif + endif + + DM_BCAST_MACRO(tnccn_act) + + end subroutine table_ccnAct + +!================================================================================================================= + end module mpas_atmphys_init_microphysics +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F index 303c1ce337..d6dc1bc0c1 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F +++ b/src/core_atmosphere/physics/mpas_atmphys_initialize_real.F @@ -49,6 +49,16 @@ module mpas_atmphys_initialize_real ! * In subroutine physics_init_seaice, assign the sea-ice land use category as a function of ! the land use category input file (MODIS OR USGS). ! Dominikus Heinzeller (IMK) / 2014-07-24. +! * In subroutine physics_init_seaice, removed the initialization of isice_lu since it is now defined in +! Registry.xml and initialized in subroutine init_atm_static. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-12. +! * In subroutine physics_init_seaice, added the initialization of the annual maximum snow albedo over seaice +! points to 0.75. +! * Laura D. Fowler (laura@ucar.edu) / 2022-03-15). +! * In subroutine physics_init_seaice, corrected the initialization of seaice points when the surface +! temperature was originally colder than 271K. We now use the seaice threshold config_tsk_seaice_threshold +! that has a default value set to 100K. This leads to decreased seaice at high latitudes. +! Laura D. Fowler (laura@ucar.edu) / 2022-03-25. contains @@ -593,34 +603,37 @@ subroutine physics_init_seaice(mesh, input, dims, configs) real(kind=RKIND):: xice_threshold real(kind=RKIND):: mid_point_depth + real(kind=RKIND),pointer:: tsk_seaice_threshold real(kind=RKIND),dimension(:),pointer :: vegfra - real(kind=RKIND),dimension(:),pointer :: seaice,xice + real(kind=RKIND),dimension(:),pointer :: seaice,snoalb,xice real(kind=RKIND),dimension(:),pointer :: skintemp,tmn,xland real(kind=RKIND),dimension(:,:),pointer:: tslb,smois,sh2o,smcrel logical, pointer :: config_frac_seaice character(len=StrKIND),pointer:: config_landuse_data - integer:: isice_lu + integer,pointer:: isice_lu !note that this threshold is also defined in module_physics_vars.F.It is defined here to avoid !adding "use module_physics_vars" since this subroutine is only used for the initialization of !a "real" forecast with $CORE = init_nhyd_atmos. - real(kind=RKIND),parameter:: xice_tsk_threshold = 271. real(kind=RKIND),parameter:: total_depth = 3. ! 3-meter soil depth. !----------------------------------------------------------------------------------------------------------------- !call mpas_log_write('') !call mpas_log_write('--- enter physics_init_seaice:') - call mpas_pool_get_config(configs, 'config_frac_seaice', config_frac_seaice) - call mpas_pool_get_config(configs, 'config_landuse_data', config_landuse_data) + call mpas_pool_get_config(configs, 'config_frac_seaice' , config_frac_seaice) + call mpas_pool_get_config(configs, 'config_tsk_seaice_threshold', tsk_seaice_threshold) + call mpas_pool_get_config(configs, 'config_landuse_data' , config_landuse_data) call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(dims, 'nSoilLevels', nSoilLevels) + call mpas_pool_get_array(mesh, 'isice_lu', isice_lu) call mpas_pool_get_array(mesh, 'landmask', landmask) call mpas_pool_get_array(mesh, 'lu_index', ivgtyp) call mpas_pool_get_array(mesh, 'soilcat_top', isltyp) + call mpas_pool_get_array(mesh, 'snoalb', snoalb) call mpas_pool_get_array(input, 'seaice', seaice) call mpas_pool_get_array(input, 'xice', xice) @@ -635,17 +648,6 @@ subroutine physics_init_seaice(mesh, input, dims, configs) call mpas_pool_get_array(input, 'sh2o', sh2o) call mpas_pool_get_array(input, 'smcrel', smcrel) -!define the land use category for sea-ice as a function of the land use category input file: - sfc_input_select1: select case(trim(config_landuse_data)) - case('OLD') - isice_lu = 11 - case('USGS') - isice_lu = 24 - case('MODIFIED_IGBP_MODIS_NOAH') - isice_lu = 15 - case default - CALL physics_error_fatal ('Invalid Land Use Dataset '//trim(config_landuse_data)) - end select sfc_input_select1 call mpas_log_write('--- isice_lu = $i', intArgs=(/isice_lu/)) !assign the threshold value for xice as a function of config_frac_seaice: @@ -663,19 +665,21 @@ subroutine physics_init_seaice(mesh, input, dims, configs) endif call mpas_log_write('--- config_frac_seaice : $l', logicArgs=(/config_frac_seaice/)) call mpas_log_write('--- xice_threshold : $r', realArgs=(/xice_threshold/)) + call mpas_log_write('--- tsk_seaice_threshold : $r', realArgs=(/tsk_seaice_threshold/)) !convert seaice points to land points when the sea-ice fraction is greater than the !prescribed threshold: num_seaice_changes = 0 do iCell = 1, nCellsSolve if(xice(iCell) .ge. xice_threshold .or. & - (landmask(iCell).eq.0 .and. skintemp(iCell).lt.xice_tsk_threshold)) then + (landmask(iCell).eq.0 .and. skintemp(iCell).lt.tsk_seaice_threshold)) then num_seaice_changes = num_seaice_changes + 1 !... sea-ice points are converted to land points: if(landmask(iCell) .eq. 0) tmn(iCell) = 271.4_RKIND ivgtyp(iCell) = isice_lu isltyp(iCell) = 16 + snoalb(iCell) = 0.75 vegfra(iCell) = 0._RKIND xland(iCell) = 1._RKIND diff --git a/src/core_atmosphere/physics/mpas_atmphys_interface.F b/src/core_atmosphere/physics/mpas_atmphys_interface.F index f4ec446521..40125972ab 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_interface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_interface.F @@ -77,11 +77,12 @@ subroutine allocate_forall_physics(configs) type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: microp_scheme,pbl_scheme !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) if(.not.allocated(psfc_p) ) allocate(psfc_p(ims:ime,jms:jme) ) if(.not.allocated(ptop_p) ) allocate(ptop_p(ims:ime,jms:jme) ) @@ -114,12 +115,22 @@ subroutine allocate_forall_physics(configs) if(.not.allocated(qs_p) ) allocate(qs_p(ims:ime,kms:kme,jms:jme) ) if(.not.allocated(qg_p) ) allocate(qg_p(ims:ime,kms:kme,jms:jme) ) - pbl_select: select case (trim(pbl_scheme)) + microp_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(.not.allocated(nifa_p)) allocate(nifa_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(nwfa_p)) allocate(nwfa_p(ims:ime,kms:kme,jms:jme)) + + case default + end select microp_select + + pbl_select: select case(trim(pbl_scheme)) case("bl_mynn") + if(.not.allocated(nc_p)) allocate(nc_p(ims:ime,kms:kme,jms:jme)) if(.not.allocated(ni_p)) allocate(ni_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(nifa_p)) allocate(nifa_p(ims:ime,kms:kme,jms:jme)) + if(.not.allocated(nwfa_p)) allocate(nwfa_p(ims:ime,kms:kme,jms:jme)) case default - end select pbl_select !... arrays used for calculating the hydrostatic pressure and exner function: @@ -141,11 +152,12 @@ subroutine deallocate_forall_physics(configs) type(mpas_pool_type),intent(in):: configs !local pointers: - character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: microp_scheme,pbl_scheme !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) if(allocated(psfc_p) ) deallocate(psfc_p ) if(allocated(ptop_p) ) deallocate(ptop_p ) @@ -178,12 +190,22 @@ subroutine deallocate_forall_physics(configs) if(allocated(qs_p) ) deallocate(qs_p ) if(allocated(qg_p) ) deallocate(qg_p ) - pbl_select: select case (trim(pbl_scheme)) + microp_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + if(allocated(nifa_p)) deallocate(nifa_p) + if(allocated(nwfa_p)) deallocate(nwfa_p) + + case default + end select microp_select + + pbl_select: select case(trim(pbl_scheme)) case("bl_mynn") + if(allocated(nc_p)) deallocate(nc_p) if(allocated(ni_p)) deallocate(ni_p) + if(allocated(nifa_p)) deallocate(nifa_p) + if(allocated(nwfa_p)) deallocate(nwfa_p) case default - end select pbl_select if(allocated(psfc_hyd_p) ) deallocate(psfc_hyd_p ) @@ -213,10 +235,10 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite type(mpas_pool_type),intent(inout):: diag_physics !local pointers: - character(len=StrKIND),pointer:: pbl_scheme + character(len=StrKIND),pointer:: microp_scheme,pbl_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni + integer,pointer:: index_nc,index_ni,index_nifa,index_nwfa real(kind=RKIND),dimension(:),pointer :: latCell,lonCell real(kind=RKIND),dimension(:),pointer :: fzm,fzp,rdzw @@ -225,7 +247,7 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite real(kind=RKIND),dimension(:,:),pointer :: zz,exner,pressure_b,rtheta_p,rtheta_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p,u,v,w real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg - real(kind=RKIND),dimension(:,:),pointer :: ni + real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nifa,nwfa real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: @@ -246,7 +268,8 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite !call mpas_log_write('kts=$i kte=$i',intArgs=(/kts,kte/)) !initialization: - call mpas_pool_get_config(configs,'config_pbl_scheme',pbl_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_pbl_scheme' ,pbl_scheme ) call mpas_pool_get_array(mesh,'latCell',latCell) call mpas_pool_get_array(mesh,'lonCell',lonCell) @@ -318,21 +341,74 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite enddo enddo - pbl_select: select case (trim(pbl_scheme)) - case("bl_mynn") - call mpas_pool_get_dimension(state,'index_ni',index_ni) - ni => scalars(index_ni,:,:) - + microp_select: select case(trim(microp_scheme)) + case("mp_thompson_aerosols") + nullify(nifa) + nullify(nwfa) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) do j = jts,jte - do k = kts,kte - do i = its,ite - ni_p(i,k,j) = max(0.,ni(k,i)) - enddo - enddo + do k = kts,kte + do i = its,ite + nifa_p(i,k,j) = max(0.,nifa(k,i)) + nwfa_p(i,k,j) = max(0.,nwfa(k,i)) + enddo + enddo enddo case default + end select microp_select + + pbl_select: select case(trim(pbl_scheme)) + case("bl_mynn") + do j = jts,jte + do k = kts,kte + do i = its,ite + nc_p(i,k,j) = 0._RKIND + ni_p(i,k,j) = 0._RKIND + nifa_p(i,k,j) = 0._RKIND + nwfa_p(i,k,j) = 0._RKIND + enddo + enddo + enddo + !initializes ni_p when running the options "mp_thompson" or "mp_thompson_aerosols": + if(f_ni) then + nullify(ni) + call mpas_pool_get_dimension(state,'index_ni',index_ni) + ni => scalars(index_ni,:,:) + do j = jts,jte + do k = kts,kte + do i = its,ite + ni_p(i,k,j) = max(0.,ni(k,i)) + enddo + enddo + enddo + endif + !initializes nc_p, nifa_p, and nwfa_p when running the option "mp_thompson_aerosols": + if(f_nc .and. f_nifa .and. f_nwfa) then + nullify(nc) + nullify(nifa) + nullify(nwfa) + call mpas_pool_get_dimension(state,'index_nc',index_nc) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nc => scalars(index_nc,:,:) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + do j = jts,jte + do k = kts,kte + do i = its,ite + nc_p(i,k,j) = max(0.,nc(k,i)) + nifa_p(i,k,j) = max(0.,nifa(k,i)) + nwfa_p(i,k,j) = max(0.,nwfa(k,i)) + enddo + enddo + enddo + endif + case default end select pbl_select !calculation of the surface pressure using hydrostatic assumption down to the surface:: @@ -470,7 +546,7 @@ subroutine MPAS_to_physics(configs,mesh,state,time_lev,diag,diag_physics,its,ite end subroutine MPAS_to_physics !================================================================================================================= - subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,its,ite) + subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,its,ite) !================================================================================================================= !input variables: @@ -483,18 +559,23 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, integer,intent(in):: its,ite integer:: time_lev +!inout variables: + type(mpas_pool_type),intent(inout):: tend_physics + !local pointers: - character(len=StrKIND),pointer:: microp_scheme + character(len=StrKIND),pointer:: mp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni,index_nr - real(kind=RKIND),dimension(:),pointer :: nt_c,mu_c + integer,pointer:: index_nc,index_ni,index_nr,index_nifa,index_nwfa + real(kind=RKIND),dimension(:),pointer :: nifa2d,nwfa2d,nt_c,mu_c real(kind=RKIND),dimension(:,:),pointer :: zgrid,w real(kind=RKIND),dimension(:,:),pointer :: zz,exner,pressure_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg - real(kind=RKIND),dimension(:,:),pointer :: ni,nr + real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nr,nifa,nwfa real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod real(kind=RKIND),dimension(:,:),pointer :: re_cloud,re_ice,re_snow + real(kind=RKIND),dimension(:,:),pointer :: rthmpten,rqvmpten,rqcmpten,rqrmpten,rqimpten,rqsmpten,rqgmpten + real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: @@ -502,7 +583,7 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',mp_scheme) call mpas_pool_get_array(mesh,'zgrid',zgrid) call mpas_pool_get_array(mesh,'zz' ,zz ) @@ -511,31 +592,17 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, call mpas_pool_get_array(diag,'pressure_base',pressure_b) call mpas_pool_get_array(diag,'pressure_p' ,pressure_p) - call mpas_pool_get_array(diag_physics,'nt_c' ,nt_c ) - call mpas_pool_get_array(diag_physics,'mu_c' ,mu_c ) - call mpas_pool_get_array(diag_physics,'rainprod',rainprod) - call mpas_pool_get_array(diag_physics,'evapprod',evapprod) - call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) - call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) - call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) - call mpas_pool_get_array(state,'rho_zz' ,rho_zz ,time_lev) call mpas_pool_get_array(state,'theta_m',theta_m,time_lev) call mpas_pool_get_array(state,'w' ,w ,time_lev) - call mpas_pool_get_dimension(state,'index_qv' ,index_qv ) - 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 ) - call mpas_pool_get_dimension(state,'index_ni' ,index_ni ) - call mpas_pool_get_dimension(state,'index_nr' ,index_nr ) - + call mpas_pool_get_dimension(state,'index_qv',index_qv) + call mpas_pool_get_dimension(state,'index_qc',index_qc) + call mpas_pool_get_dimension(state,'index_qr',index_qr) call mpas_pool_get_array(state,'scalars',scalars,time_lev) - qv => scalars(index_qv,:,:) - qc => scalars(index_qc,:,:) - qr => scalars(index_qr,:,:) + qv => scalars(index_qv,:,:) + qc => scalars(index_qc,:,:) + qr => scalars(index_qr,:,:) !initialize variables needed in the cloud microphysics schemes: do j = jts, jte @@ -558,13 +625,21 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, enddo enddo -!additional initialization as function of cloud microphysics scheme: - microp_select_init: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") - qi => scalars(index_qi,:,:) - qs => scalars(index_qs,:,:) - qg => scalars(index_qg,:,:) +!initialize cloud water species and aerosols as function of cloud microphysics scheme: + mp_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + 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) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + + call mpas_pool_get_array(diag_physics,'rainprod',rainprod) + call mpas_pool_get_array(diag_physics,'evapprod',evapprod) + call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) + call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) + call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) do j = jts, jte do k = kts, kte @@ -572,76 +647,168 @@ subroutine microphysics_from_MPAS(configs,mesh,state,time_lev,diag,diag_physics, qi_p(i,k,j) = qi(k,i) qs_p(i,k,j) = qs(k,i) qg_p(i,k,j) = qg(k,i) + + rainprod_p(i,k,j) = rainprod(k,i) + evapprod_p(i,k,j) = evapprod(k,k) + recloud_p(i,k,j) = re_cloud(k,i) + reice_p(i,k,j) = re_ice(k,i) + resnow_p(i,k,j) = re_snow(k,i) enddo enddo enddo - microp2_select: select case(microp_scheme) + mp2_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_ni',index_ni) + call mpas_pool_get_dimension(state,'index_nr',index_nr) + ni => scalars(index_ni,:,:) + nr => scalars(index_nr,:,:) + + call mpas_pool_get_array(diag_physics,'nt_c',nt_c) + call mpas_pool_get_array(diag_physics,'mu_c',mu_c) + do j = jts,jte + do i = its,ite + muc_p(i,j) = mu_c(i) + ntc_p(i,j) = nt_c(i) + enddo + do k = kts, kte + do i = its, ite + ni_p(i,k,j) = ni(k,i) + nr_p(i,k,j) = nr(k,i) + enddo + enddo + enddo + + mp3_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_nc' ,index_nc ) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nc => scalars(index_nc,:,:) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + call mpas_pool_get_array(diag_physics,'nifa2d',nifa2d) + call mpas_pool_get_array(diag_physics,'nwfa2d',nwfa2d) + do j = jts,jte + do i = its,ite + nifa2d_p(i,j) = nifa2d(i) + nwfa2d_p(i,j) = nwfa2d(i) + enddo + do k = kts, kte + do i = its, ite + nc_p(i,k,j) = nc(k,i) + nifa_p(i,k,j) = nifa(k,i) + nwfa_p(i,k,j) = nwfa(k,i) + enddo + enddo + enddo + + case default + end select mp3_select + + case default + end select mp2_select - case("mp_thompson") - ni => scalars(index_ni,:,:) - nr => scalars(index_nr,:,:) - - do j = jts,jte - do i = its,ite - muc_p(i,j) = mu_c(i) - ntc_p(i,j) = nt_c(i) - enddo - enddo - do j = jts, jte - do k = kts, kte - do i = its, ite - ni_p(i,k,j) = ni(k,i) - nr_p(i,k,j) = nr(k,i) - rainprod_p(i,k,j) = rainprod(k,i) - evapprod_p(i,k,j) = evapprod(k,i) - recloud_p(i,k,j) = re_cloud(k,i) - reice_p(i,k,j) = re_ice(k,i) - resnow_p(i,k,j) = re_snow(k,i) - enddo - enddo - enddo + case default + end select mp_select + +!begin calculation of cloud microphysics tendencies: + mp_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + call mpas_pool_get_array(tend_physics,'rthmpten',rthmpten) + call mpas_pool_get_array(tend_physics,'rqvmpten',rqvmpten) + call mpas_pool_get_array(tend_physics,'rqcmpten',rqcmpten) + call mpas_pool_get_array(tend_physics,'rqrmpten',rqrmpten) + call mpas_pool_get_array(tend_physics,'rqimpten',rqimpten) + call mpas_pool_get_array(tend_physics,'rqsmpten',rqsmpten) + call mpas_pool_get_array(tend_physics,'rqgmpten',rqgmpten) - case default + do k = kts,kte + do i = its,ite + rthmpten(k,i) = theta_m(k,i)/(1._RKIND+R_v/R_d*max(0._RKIND,qv(k,i))) + rqvmpten(k,i) = qv(k,i) + rqcmpten(k,i) = qc(k,i) + rqrmpten(k,i) = qr(k,i) + rqimpten(k,i) = qi(k,i) + rqsmpten(k,i) = qs(k,i) + rqgmpten(k,i) = qg(k,i) + enddo + enddo - end select microp2_select + mp2_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rnimpten',rnimpten) + call mpas_pool_get_array(tend_physics,'rnrmpten',rnrmpten) + + do k = kts,kte + do i = its,ite + rnimpten(k,i) = ni(k,i) + rnrmpten(k,i) = nr(k,i) + enddo + enddo + + mp3_tend_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rncmpten',rncmpten) + call mpas_pool_get_array(tend_physics,'rnifampten',rnifampten) + call mpas_pool_get_array(tend_physics,'rnwfampten',rnwfampten) + + do k = kts,kte + do i = its,ite + rncmpten(k,i) = nc(k,i) + rnifampten(k,i) = nifa(k,i) + rnwfampten(k,i) = nwfa(k,i) + enddo + enddo + + case default + end select mp3_tend_select + + case default + end select mp2_tend_select case default - - end select microp_select_init + end select mp_tend_select end subroutine microphysics_from_MPAS !================================================================================================================= - subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend,itimestep,its,ite) + subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,tend_physics,tend,its,ite) !================================================================================================================= !input variables: type(mpas_pool_type),intent(in):: configs type(mpas_pool_type),intent(in):: mesh - integer,intent(in):: itimestep,time_lev + integer,intent(in):: time_lev integer,intent(in):: its,ite -!output variables: +!inout variables: type(mpas_pool_type),intent(inout):: state type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: tend_physics + !local pointers: - character(len=StrKIND),pointer:: microp_scheme + character(len=StrKIND),pointer:: mp_scheme integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs,index_qg - integer,pointer:: index_ni,index_nr + integer,pointer:: index_nc,index_ni,index_nr,index_nifa,index_nwfa real(kind=RKIND),dimension(:),pointer :: surface_pressure,tend_sfc_pressure + real(kind=RKIND),dimension(:),pointer :: nifa2d,nwfa2d real(kind=RKIND),dimension(:,:),pointer :: zgrid real(kind=RKIND),dimension(:,:),pointer :: zz,exner,exner_b,pressure_b,rtheta_p,rtheta_b real(kind=RKIND),dimension(:,:),pointer :: rho_zz,theta_m,pressure_p real(kind=RKIND),dimension(:,:),pointer :: rt_diabatic_tend + real(kind=RKIND),dimension(:,:),pointer :: dtheta_dt_mp real(kind=RKIND),dimension(:,:),pointer :: qv,qc,qr,qi,qs,qg - real(kind=RKIND),dimension(:,:),pointer :: ni,nr + real(kind=RKIND),dimension(:,:),pointer :: nc,ni,nr,nifa,nwfa real(kind=RKIND),dimension(:,:),pointer :: rainprod,evapprod real(kind=RKIND),dimension(:,:),pointer :: re_cloud,re_ice,re_snow + real(kind=RKIND),dimension(:,:),pointer :: rthmpten,rqvmpten,rqcmpten,rqrmpten,rqimpten,rqsmpten,rqgmpten + real(kind=RKIND),dimension(:,:),pointer :: rncmpten,rnimpten,rnrmpten,rnifampten,rnwfampten real(kind=RKIND),dimension(:,:,:),pointer:: scalars !local variables: @@ -651,7 +818,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_config(configs,'config_microp_scheme',microp_scheme) + call mpas_pool_get_config(configs,'config_microp_scheme',mp_scheme) call mpas_pool_get_array(mesh,'zz' ,zz ) call mpas_pool_get_array(mesh,'zgrid',zgrid) @@ -663,12 +830,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_array(diag,'rtheta_base' ,rtheta_b ) call mpas_pool_get_array(diag,'rtheta_p' ,rtheta_p ) call mpas_pool_get_array(diag,'surface_pressure',surface_pressure) - - call mpas_pool_get_array(diag_physics,'rainprod',rainprod) - call mpas_pool_get_array(diag_physics,'evapprod',evapprod) - call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) - call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) - call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) + call mpas_pool_get_array(diag,'dtheta_dt_mp' ,dtheta_dt_mp ) call mpas_pool_get_array(tend,'tend_sfc_pressure',tend_sfc_pressure) @@ -678,12 +840,6 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te call mpas_pool_get_dimension(state,'index_qv' ,index_qv ) 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 ) - call mpas_pool_get_dimension(state,'index_ni' ,index_ni ) - call mpas_pool_get_dimension(state,'index_nr' ,index_nr ) - call mpas_pool_get_array(state,'scalars',scalars,time_lev) qv => scalars(index_qv,:,:) qc => scalars(index_qc,:,:) @@ -695,14 +851,21 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te do j = jts,jte do k = kts,kte do i = its,ite + + !initializes tendency of coupled potential temperature potential temperature, and + !potential temperature heating rate from microphysics: + rt_diabatic_tend(k,i) = theta_m(k,i) + dtheta_dt_mp(k,i) = theta_m(k,i)/(1._RKIND+rvord*qv(k,i)) + + !updates water vapor, cloud liquid water, rain mixing ratios, modified potential temperature, + !tendency of coupled potential temperature, and potential temperature heating rate from microphysics: qv(k,i) = qv_p(i,k,j) qc(k,i) = qc_p(i,k,j) qr(k,i) = qr_p(i,k,j) - !potential temperature and diabatic forcing: - rt_diabatic_tend(k,i) = theta_m(k,i) - theta_m(k,i) = th_p(i,k,j) * (1. + R_v/R_d * qv_p(i,k,j)) - rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i)) / dt_dyn + theta_m(k,i) = th_p(i,k,j) * (1._RKIND+rvord*qv_p(i,k,j)) + rt_diabatic_tend(k,i) = (theta_m(k,i) - rt_diabatic_tend(k,i))/dt_dyn + dtheta_dt_mp(k,i) = (theta_m(k,i)/(1._RKIND+rvord*qv(k,i))-dtheta_dt_mp(k,i))/(dt_dyn) !density-weighted perturbation potential temperature: rtheta_p(k,i) = rho_zz(k,i) * theta_m(k,i) - rtheta_b(k,i) @@ -718,7 +881,7 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo -!updates the surface pressure and calculates the surface pressure tendency: +!update surface pressure and calculates the surface pressure tendency: do j = jts,jte do i = its,ite tem1 = zgrid(2,i)-zgrid(1,i) @@ -736,51 +899,145 @@ subroutine microphysics_to_MPAS(configs,mesh,state,time_lev,diag,diag_physics,te enddo enddo -!variables specific to different cloud microphysics schemes: - microp_select_init: select case(microp_scheme) - - case ("mp_thompson","mp_wsm6") - qi => scalars(index_qi,:,:) - qs => scalars(index_qs,:,:) - qg => scalars(index_qg,:,:) +!update cloud water species and aerosols as functions of cloud microphysics schemes: + mp_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + 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) + qi => scalars(index_qi,:,:) + qs => scalars(index_qs,:,:) + qg => scalars(index_qg,:,:) + + call mpas_pool_get_array(diag_physics,'rainprod',rainprod) + call mpas_pool_get_array(diag_physics,'evapprod',evapprod) + call mpas_pool_get_array(diag_physics,'re_cloud',re_cloud) + call mpas_pool_get_array(diag_physics,'re_ice' ,re_ice ) + call mpas_pool_get_array(diag_physics,'re_snow' ,re_snow ) - do j = jts, jte - do k = kts, kte - do i = its, ite + do j = jts,jte + do k = kts,kte + do i = its,ite qi(k,i) = qi_p(i,k,j) qs(k,i) = qs_p(i,k,j) qg(k,i) = qg_p(i,k,j) + + rainprod(k,i) = rainprod_p(i,k,j) + evapprod(k,i) = evapprod_p(i,k,j) + re_cloud(k,i) = recloud_p(i,k,j) + re_ice(k,i) = reice_p(i,k,j) + re_snow(k,i) = resnow_p(i,k,j) enddo enddo enddo - microp2_select: select case(microp_scheme) - - case("mp_thompson") - ni => scalars(index_ni,:,:) - nr => scalars(index_nr,:,:) - - do j = jts, jte - do k = kts, kte - do i = its, ite - ni(k,i) = ni_p(i,k,j) - nr(k,i) = nr_p(i,k,j) - rainprod(k,i) = rainprod_p(i,k,j) - evapprod(k,i) = evapprod_p(i,k,j) - re_cloud(k,i) = recloud_p(i,k,j) - re_ice(k,i) = reice_p(i,k,j) - re_snow(k,i) = resnow_p(i,k,j) - enddo - enddo - enddo + mp2_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_ni',index_ni) + call mpas_pool_get_dimension(state,'index_nr',index_nr) + ni => scalars(index_ni,:,:) + nr => scalars(index_nr,:,:) + + do j = jts,jte + do k = kts,kte + do i = its,ite + ni(k,i) = ni_p(i,k,j) + nr(k,i) = nr_p(i,k,j) + enddo + enddo + enddo + + mp3_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_dimension(state,'index_nc' ,index_nc ) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + nc => scalars(index_nc,:,:) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + call mpas_pool_get_array(diag_physics,'nifa2d',nifa2d) + call mpas_pool_get_array(diag_physics,'nwfa2d',nwfa2d) + do j = jts,jte + do i = its,ite + nifa2d(i) = nifa2d_p(i,j) + nwfa2d(i) = nwfa2d_p(i,j) + enddo + do k = kts, kte + do i = its, ite + nc(k,i) = nc_p(i,k,j) + nifa(k,i) = nifa_p(i,k,j) + nwfa(k,i) = nwfa_p(i,k,j) + enddo + enddo + enddo + + case default + end select mp3_select + + case default + end select mp2_select - case default + case default + end select mp_select + +!end calculation of cloud microphysics tendencies: + mp_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols","mp_wsm6") + call mpas_pool_get_array(tend_physics,'rthmpten',rthmpten) + call mpas_pool_get_array(tend_physics,'rqvmpten',rqvmpten) + call mpas_pool_get_array(tend_physics,'rqcmpten',rqcmpten) + call mpas_pool_get_array(tend_physics,'rqrmpten',rqrmpten) + call mpas_pool_get_array(tend_physics,'rqimpten',rqimpten) + call mpas_pool_get_array(tend_physics,'rqsmpten',rqsmpten) + call mpas_pool_get_array(tend_physics,'rqgmpten',rqgmpten) - end select microp2_select + do k = kts,kte + do i = its,ite + rthmpten(k,i) = (theta_m(k,i)/(1._RKIND+R_v/R_d*max(0._RKIND,qv(k,i)))-rthmpten(k,i))/dt_dyn + rqvmpten(k,i) = (qv(k,i)-rqvmpten(k,i))/dt_dyn + rqcmpten(k,i) = (qc(k,i)-rqcmpten(k,i))/dt_dyn + rqrmpten(k,i) = (qr(k,i)-rqrmpten(k,i))/dt_dyn + rqimpten(k,i) = (qi(k,i)-rqimpten(k,i))/dt_dyn + rqsmpten(k,i) = (qs(k,i)-rqsmpten(k,i))/dt_dyn + rqgmpten(k,i) = (qg(k,i)-rqgmpten(k,i))/dt_dyn + enddo + enddo - case default + mp2_tend_select: select case(trim(mp_scheme)) + case("mp_thompson","mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rnimpten',rnimpten) + call mpas_pool_get_array(tend_physics,'rnrmpten',rnrmpten) + + do k = kts,kte + do i = its,ite + rnimpten(k,i) = (ni(k,i)-rnimpten(k,i))/dt_dyn + rnrmpten(k,i) = (nr(k,i)-rnrmpten(k,i))/dt_dyn + enddo + enddo + + mp3_tend_select: select case(trim(mp_scheme)) + case("mp_thompson_aerosols") + call mpas_pool_get_array(tend_physics,'rncmpten',rncmpten) + call mpas_pool_get_array(tend_physics,'rnifampten',rnifampten) + call mpas_pool_get_array(tend_physics,'rnwfampten',rnwfampten) + + do k = kts,kte + do i = its,ite + rncmpten(k,i) = (nc(k,i)-rncmpten(k,i))/dt_dyn + rnifampten(k,i) = (nifa(k,i)-rnifampten(k,i))/dt_dyn + rnwfampten(k,i) = (nwfa(k,i)-rnwfampten(k,i))/dt_dyn + enddo + enddo + + case default + end select mp3_tend_select + + case default + end select mp2_tend_select - end select microp_select_init + case default + end select mp_tend_select end subroutine microphysics_to_MPAS diff --git a/src/core_atmosphere/physics/mpas_atmphys_landuse.F b/src/core_atmosphere/physics/mpas_atmphys_landuse.F index 0e2aa5578b..a153d09948 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_landuse.F +++ b/src/core_atmosphere/physics/mpas_atmphys_landuse.F @@ -14,6 +14,7 @@ module mpas_atmphys_landuse use mpas_dmpar use mpas_kind_types use mpas_pool_routines + use mpas_io_units use mpas_atmphys_utilities use mpas_atmphys_vars @@ -23,10 +24,7 @@ module mpas_atmphys_landuse public:: landuse_init_forMPAS !global variables: - integer,public:: isice,iswater,isurban - - integer,parameter:: frac_seaice = 0 ! = 1: treats seaice as fractional field. - ! = 0: ice/no-ice flag. + integer,public:: isurban !This module reads the file LANDUSE.TBL which defines the land type of each cell, depending on !the origin of the input data, as defined by the value of the variable "sfc_input_data". @@ -72,6 +70,12 @@ module mpas_atmphys_landuse ! * in subroutine landuse_int_forMPAS, added the initialization of variable ust to a very small value. this was ! needed when the surface layer scheme was updated to that used in WRF version 3.8.1 ! Laura D. Fowler (laura@ucar.edu) / 2016-10-27. +! * removed the parameter frac_seaice which is not used anymore and has been replaced with config_frac_seaice. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-11. +! * now use isice and iswater initialized in the init file instead of initialized in mpas_atmphys_landuse.F. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-13. +! * added the initialization of sfc_albedo_seaice which is the surface albedo over seaice points. +! Laura D. Fowler (laura@ucar.edu) / 2017-03-02. contains @@ -98,6 +102,7 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu character(len=StrKIND),pointer:: mminlu integer,pointer:: nCells + integer,pointer:: isice,iswater integer,dimension(:),pointer:: ivgtyp integer,dimension(:),pointer:: landmask @@ -110,7 +115,7 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu character(len=StrKIND) :: lutype character(len=StrKIND):: mess - integer,parameter:: land_unit = 15 + integer:: land_unit integer,parameter:: open_ok = 0 integer,parameter:: max_cats = 100 integer,parameter:: max_seas = 12 @@ -130,39 +135,46 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu call mpas_pool_get_config(configs,'config_do_restart' ,config_do_restart ) call mpas_pool_get_config(configs,'config_frac_seaice',config_frac_seaice) call mpas_pool_get_config(configs,'config_sfc_albedo' ,config_sfc_albedo ) - call mpas_pool_get_array(sfc_input,'mminlu',mminlu) call mpas_pool_get_dimension(mesh,'nCells',nCells) call mpas_pool_get_array(mesh,'latCell',latCell) - call mpas_pool_get_array(sfc_input,'landmask' , landmask ) - call mpas_pool_get_array(sfc_input,'ivgtyp' , ivgtyp ) - call mpas_pool_get_array(sfc_input,'snoalb' , snoalb ) - call mpas_pool_get_array(sfc_input,'snowc' , snowc ) - 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,'sfc_albbck', albbck ) + call mpas_pool_get_array(sfc_input,'mminlu' ,mminlu ) + call mpas_pool_get_array(sfc_input,'isice' ,isice ) + call mpas_pool_get_array(sfc_input,'iswater' ,iswater ) + call mpas_pool_get_array(sfc_input,'landmask' ,landmask) + call mpas_pool_get_array(sfc_input,'ivgtyp' ,ivgtyp ) + call mpas_pool_get_array(sfc_input,'snoalb' ,snoalb ) + call mpas_pool_get_array(sfc_input,'snowc' ,snowc ) + 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,'sfc_albbck',albbck ) nullify(mavail) nullify(ust) - call mpas_pool_get_array(diag_physics,'sfc_emibck', embck ) - call mpas_pool_get_array(diag_physics,'mavail' , mavail ) - 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,'thc' , thc ) - call mpas_pool_get_array(diag_physics,'ust' , ust ) - call mpas_pool_get_array(diag_physics,'xicem' , xicem ) - 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,'sfc_emibck' ,embck ) + call mpas_pool_get_array(diag_physics,'mavail' ,mavail ) + 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,'thc' ,thc ) + call mpas_pool_get_array(diag_physics,'ust' ,ust ) + call mpas_pool_get_array(diag_physics,'xicem' ,xicem ) + call mpas_pool_get_array(diag_physics,'z0' ,z0 ) + call mpas_pool_get_array(diag_physics,'znt' ,znt ) + !call mpas_log_write('') -!call mpas_log_write('--- enter subroutine landuse_init_forMPAS: julian day=$i', intArgs=(/julday/)) -!call mpas_log_write('--- config_frac_seaice = $l', logicArgs=(/config_frac_seaice/)) -!call mpas_log_write('--- xice_threshold = $r', realArgs=(/xice_threshold/)) +!call mpas_log_write('--- enter subroutine landuse_init_forMPAS: julian day=$i' , intArgs=(/julday/)) +!call mpas_log_write('--- config_frac_seaice = $1',logicArgs=(/config_frac_seaice/)) +!call mpas_log_write('--- xice_threshold = $r',realArgs=(/xice_threshold/)) !reads in the landuse properties from landuse.tbl: if(dminfo % my_proc_id == IO_NODE) then + !get a unit to open init file: + call mpas_new_unit(land_unit) + if ( land_unit < 0 ) & + call physics_error_fatal('landuse_init_forMPAS: All file units are taken. Change maxUnits in mpas_io_units.F') + open(land_unit,file='LANDUSE.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine landuse_init_forMPAS: ' // & @@ -197,33 +209,27 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu therin(ic,is),scfx(ic,is),sfhc(ic,is) enddo ! do ic = 1, lucats -! call mpas_log_write('$i $r $r $r $r $r $r $r $r', intArgs=(/ic/), realArgs=(/albd(ic,is),slmo(ic,is),sfem(ic,is),sfz0(ic,is), & +! call mpas_log_write('$i $r $r $r $r $r $r $r', intArgs=(/ic/), & +! realArgs=(/albd(ic,is),slmo(ic,is),sfem(ic,is),sfz0(ic,is), & ! therin(ic,is),scfx(ic,is),sfhc(ic,is)/)) ! enddo ! if(is .lt. luseas) call mpas_log_write('') enddo -!defines the index isurban, iswater and, isice as a function of sfc_input_data: + close(land_unit) + call mpas_release_unit(land_unit) + +!defines the index isurban as a function of sfc_input_data: sfc_input_select: select case(trim(lutype)) case('OLD') - iswater = 7 - isice = 11 isurban = 1 case('USGS') - iswater = 16 - isice = 24 isurban = 1 case('MODIFIED_IGBP_MODIS_NOAH') - iswater = 17 - isice = 15 isurban = 13 case('SiB') - iswater = 15 - isice = 16 isurban = 11 case('LW12') - iswater = 2 - isice = 3 isurban = 1 case default end select sfc_input_select @@ -260,7 +266,6 @@ subroutine landuse_init_forMPAS(dminfo,julday,mesh,configs,diag_physics,sfc_inpu if(julday.lt.105 .or. julday.ge.288) isn=2 if(latCell(iCell) .lt. 0.) isn=3-isn -! is = nint(ivgtyp(iCell)) is = ivgtyp(iCell) !set no data points to water: diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F index 497603a94c..07481fd6ff 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahinit.F @@ -16,6 +16,7 @@ module mpas_atmphys_lsm_noahinit use mpas_dmpar use mpas_kind_types use mpas_pool_routines + use mpas_io_units use mpas_atmphys_constants use mpas_atmphys_utilities @@ -42,6 +43,10 @@ module mpas_atmphys_lsm_noahinit ! Laura D. Fowler (laura@ucar.edu) / 2014-03-21. ! * added "use mpas_kind_types" at the top of the module. ! Laura D. Fowler (laura@ucar.edu) / 2014-09-18. +! * in subroutine soil_veg_gen_parm, modified reading the updated file VEGPARM.TBL so that we can update the NOAH +! land surface scheme.added the categories low_density_residential,high_density_residential,and high_intensity_ +! industrial.added the variables ztopvtbl and zbotvtbl. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-25. contains @@ -210,11 +215,13 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) character(len=*),intent(inout):: mminlu, mminsl !local variables: - character*128:: mess , message + character*128:: mess,message + character*128:: astring - integer,parameter:: open_ok = 0 + integer,parameter:: open_ok = 0 + integer,parameter:: loop_max = 10 integer:: lumatch,iindex,lc,num_slope - integer:: istat + integer:: istat,loop_count,read_unit !-----SPECIFY VEGETATION RELATED CHARACTERISTICS : !ALBBCK: SFC albedo (in percentage) @@ -245,16 +252,23 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !read in the vegetation properties from vegparm.tbl: if(dminfo % my_proc_id == IO_NODE) then - open(16,file='VEGPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) + !get a unit to open init file: + call mpas_new_unit(read_unit) + if ( read_unit < 0 ) & + call physics_error_fatal('soil_veg_gen_parm: All file units are taken. Change maxUnits in mpas_io_units.F') + + open(read_unit,file='VEGPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine soil_veg_gen_arm: ' // & 'failure opening VEGPARM.TBL') lumatch=0 + + loop_count = 0 + read(read_unit,fmt='(A)',end=2002) astring find_lutype : do while (lumatch == 0) - read(16,*,end=2002) - read(16,*,end=2002) lutype - read(16,*) lucats,iindex + read(read_unit,*,end=2002) lutype + read(read_unit,*) lucats,iindex if(lutype.eq.trim(mminlu))then write(mess,*) ' landuse type = ' // trim ( lutype ) // ' found', & @@ -262,10 +276,17 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) call physics_message(mess) lumatch=1 else + loop_count = loop_count + 1 call physics_message(' skipping over lutype = ' // trim ( lutype )) - do lc = 1, lucats+12 - read(16,*) - enddo + + find_vegetation_parameter_flag: do + read(read_unit,fmt='(A)',end=2002) astring + if(astring(1:21) .eq. 'Vegetation Parameters') then + exit find_vegetation_parameter_flag + elseif(loop_count .ge. loop_max) then + call physics_error_fatal('too many loops in VEGPARM.TBL') + endif + enddo find_vegetation_parameter_flag endif enddo find_lutype @@ -283,33 +304,61 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) size(z0maxtbl) < lucats .or. & size(albedomintbl) < lucats .or. & size(albedomaxtbl) < lucats .or. & + size(ztopvtbl) < lucats .or. & + size(zbotvtbl) < lucats .or. & size(emissmintbl ) < lucats .or. & size(emissmaxtbl ) < lucats) then -! call wrf_error_fatal('table sizes too small for value of lucats in module_sf_noahdrv.f') + call physics_error_fatal('table sizes too small for value of lucats in module_sf_noahdrv.f') endif if(lutype.eq.mminlu)then do lc = 1, lucats - read(16,*) iindex,shdtbl(lc),nrotbl(lc),rstbl(lc),rgltbl(lc),hstbl(lc),snuptbl(lc), & - maxalb(lc),laimintbl(lc),laimaxtbl(lc),emissmintbl(lc),emissmaxtbl(lc), & - albedomintbl(lc),albedomaxtbl(lc),z0mintbl(lc),z0maxtbl(lc) + read(read_unit,*) iindex,shdtbl(lc),nrotbl(lc),rstbl(lc),rgltbl(lc),hstbl(lc),snuptbl(lc), & + maxalb(lc),laimintbl(lc),laimaxtbl(lc),emissmintbl(lc),emissmaxtbl(lc), & + albedomintbl(lc),albedomaxtbl(lc),z0mintbl(lc),z0maxtbl(lc),ztopvtbl(lc), & + zbotvtbl(lc) enddo - read (16,*) - read (16,*)topt_data - read (16,*) - read (16,*)cmcmax_data - read (16,*) - read (16,*)cfactr_data - read (16,*) - read (16,*)rsmax_data - read (16,*) - read (16,*)bare - read (16,*) - read (16,*)natural + + read (read_unit,*) + read (read_unit,*)topt_data + read (read_unit,*) + read (read_unit,*)cmcmax_data + read (read_unit,*) + read (read_unit,*)cfactr_data + read (read_unit,*) + read (read_unit,*)rsmax_data + read (read_unit,*) + read (read_unit,*)bare + read (read_unit,*) + read (read_unit,*)natural + read (read_unit,*) + read (read_unit,*) + read (read_unit,*) + read (read_unit,*)lcz_1 + read (read_unit,*) + read (read_unit,*)lcz_2 + read (read_unit,*) + read (read_unit,*)lcz_3 + read (read_unit,*) + read (read_unit,*)lcz_4 + read (read_unit,*) + read (read_unit,*)lcz_5 + read (read_unit,*) + read (read_unit,*)lcz_6 + read (read_unit,*) + read (read_unit,*)lcz_7 + read (read_unit,*) + read (read_unit,*)lcz_8 + read (read_unit,*) + read (read_unit,*)lcz_9 + read (read_unit,*) + read (read_unit,*)lcz_10 + read (read_unit,*) + read (read_unit,*)lcz_11 endif 2002 continue - close (16) + close (read_unit) if(lumatch == 0) & call physics_error_fatal ('land use dataset '''//mminlu//''' not found in VEGPARM.TBL.') @@ -334,6 +383,8 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) DM_BCAST_REALS(emissmaxtbl) DM_BCAST_REALS(albedomintbl) DM_BCAST_REALS(albedomaxtbl) + DM_BCAST_REALS(ztopvtbl) + DM_BCAST_REALS(zbotvtbl) DM_BCAST_REALS(maxalb) DM_BCAST_REAL(topt_data) DM_BCAST_REAL(cmcmax_data) @@ -341,6 +392,17 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) DM_BCAST_REAL(rsmax_data) DM_BCAST_INTEGER(bare) DM_BCAST_INTEGER(natural) + DM_BCAST_INTEGER(lcz_1) + DM_BCAST_INTEGER(lcz_2) + DM_BCAST_INTEGER(lcz_3) + DM_BCAST_INTEGER(lcz_4) + DM_BCAST_INTEGER(lcz_5) + DM_BCAST_INTEGER(lcz_6) + DM_BCAST_INTEGER(lcz_7) + DM_BCAST_INTEGER(lcz_8) + DM_BCAST_INTEGER(lcz_9) + DM_BCAST_INTEGER(lcz_10) + DM_BCAST_INTEGER(lcz_11) !call mpas_log_write(' LUTYPE = '//trim(lutype)) !call mpas_log_write(' LUCATS = $i',intArgs=(/lucats/)) @@ -353,20 +415,31 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !call mpas_log_write(' RSMAX_DATA = $r',realArgs=(/rsmax_data/)) !call mpas_log_write(' BARE = $i',intArgs=(/bare/)) !call mpas_log_write(' NATURAL = $i',intArgs=(/natural/)) - +!call mpas_log_write(' LCZ_1 = $i', intArgs=(/lcz_1/)) +!call mpas_log_write(' LCZ_2 = $i', intArgs=(/lcz_2/)) +!call mpas_log_write(' LCZ_3 = $i', intArgs=(/lcz_3/)) +!call mpas_log_write(' LCZ_4 = $i', intArgs=(/lcz_4/)) +!call mpas_log_write(' LCZ_5 = $i', intArgs=(/lcz_5/)) +!call mpas_log_write(' LCZ_6 = $i', intArgs=(/lcz_6/)) +!call mpas_log_write(' LCZ_7 = $i', intArgs=(/lcz_7/)) +!call mpas_log_write(' LCZ_8 = $i', intArgs=(/lcz_8/)) +!call mpas_log_write(' LCZ_9 = $i', intArgs=(/lcz_9/)) +!call mpas_log_write(' LCZ_10 = $i', intArgs=(/lcz_10/)) +!call mpas_log_write(' LCZ_11 = $i', intArgs=(/lcz_11/)) !call mpas_log_write('') !do lc = 1, lucats -! call mpas_log_write('$i $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r', intArgs=(/lc/), & +! call mpas_log_write('$i $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r $r', intArgs=(/lc/), & ! realArgs=(/shdtbl(lc),float(nrotbl(lc)),rstbl(lc),rgltbl(lc),hstbl(lc),snuptbl(lc), & -! maxalb(lc),laimintbl(lc),laimaxtbl(lc),emissmintbl(lc),emissmaxtbl(lc), & -! albedomintbl(lc),albedomaxtbl(lc),z0mintbl(lc),z0maxtbl(lc)/)) +! maxalb(lc),laimintbl(lc),laimaxtbl(lc),emissmintbl(lc),emissmaxtbl(lc), & +! albedomintbl(lc),albedomaxtbl(lc),z0mintbl(lc),z0maxtbl(lc),ztopvtbl(lc), & +! zbotvtbl(lc)/)) !enddo call mpas_log_write(' end read VEGPARM.TBL') !read in soil properties from soilparm.tbl: if(dminfo % my_proc_id == IO_NODE) then - open(16,file='SOILPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) + open(read_unit,file='SOILPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('module_sf_noahlsm.F: soil_veg_gen_parm: ' // & 'failure opening SOILPARM.TBL' ) @@ -375,10 +448,10 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) call physics_message(mess) lumatch=0 - read(16,*) - read(16,2000,end=2003) sltype + read(read_unit,*) + read(read_unit,2000,end=2003) sltype 2000 format(a4) - read(16,*)slcats,iindex + read(read_unit,*)slcats,iindex if(sltype.eq.mminsl)then write(mess,*) ' soil texture classification = ', trim ( sltype ) , ' found', & slcats,' categories' @@ -401,13 +474,13 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) endif if(sltype.eq.mminsl) then do lc = 1, slcats - read(16,*) iindex,bb(lc),drysmc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & + read(read_unit,*) iindex,bb(lc),drysmc(lc),f11(lc),maxsmc(lc),refsmc(lc),satpsi(lc), & satdk(lc),satdw(lc),wltsmc(lc),qtz(lc) enddo endif 2003 continue - close(16) + close(read_unit) if(lumatch.eq.0)then call physics_message( 'soil texture in input file does not ' ) call physics_message( 'match soilparm table' ) @@ -449,13 +522,13 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) !read in general parameters from genparm.tbl: if(dminfo % my_proc_id == IO_NODE) then - open(16,file='GENPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) + open(read_unit,file='GENPARM.TBL',form='FORMATTED',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('module_sf_noahlsm.F: soil_veg_gen_parm: ' // & 'failure opening GENPARM.TBL' ) - read(16,*) - read(16,*) - read(16,*) num_slope + read(read_unit,*) + read(read_unit,*) + read(read_unit,*) num_slope slpcats=num_slope !prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008: @@ -464,33 +537,34 @@ subroutine soil_veg_gen_parm(dminfo,mminlu,mminsl) 'in module_sf_noahdrv') do lc = 1, slpcats - read(16,*)slope_data(lc) + read(read_unit,*)slope_data(lc) enddo - read(16,*) - read(16,*)sbeta_data - read(16,*) - read(16,*)fxexp_data - read(16,*) - read(16,*)csoil_data - read(16,*) - read(16,*)salp_data - read(16,*) - read(16,*)refdk_data - read(16,*) - read(16,*)refkdt_data - read(16,*) - read(16,*)frzk_data - read(16,*) - read(16,*)zbot_data - read(16,*) - read(16,*)czil_data - read(16,*) - read(16,*)smlow_data - read(16,*) - read(16,*)smhigh_data - read(16,*) - read(16,*)lvcoef_data - close(16) + read(read_unit,*) + read(read_unit,*)sbeta_data + read(read_unit,*) + read(read_unit,*)fxexp_data + read(read_unit,*) + read(read_unit,*)csoil_data + read(read_unit,*) + read(read_unit,*)salp_data + read(read_unit,*) + read(read_unit,*)refdk_data + read(read_unit,*) + read(read_unit,*)refkdt_data + read(read_unit,*) + read(read_unit,*)frzk_data + read(read_unit,*) + read(read_unit,*)zbot_data + read(read_unit,*) + read(read_unit,*)czil_data + read(read_unit,*) + read(read_unit,*)smlow_data + read(read_unit,*) + read(read_unit,*)smhigh_data + read(read_unit,*) + read(read_unit,*)lvcoef_data + close(read_unit) + call mpas_release_unit(read_unit) endif DM_BCAST_INTEGER(num_slope) diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpfinalize.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpfinalize.F new file mode 100644 index 0000000000..5e6f999b44 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpfinalize.F @@ -0,0 +1,40 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and 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_lsm_noahmpfinalize + use mpas_log,only: mpas_log_write + + use mpas_atmphys_vars,only: mpas_noahmp + use NoahmpIOVarFinalizeMod,only: NoahmpIOVarFinalizeDefault + + + private + public:: sf_noahmp_deallocate + + + contains + +!================================================================================================================= + subroutine sf_noahmp_deallocate( ) +!================================================================================================================= +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine sf_noahmp_deallocate:') + + +!--- deallocate Noahmp arrays: + call NoahmpIOVarFinalizeDefault(mpas_noahmp) + + +!call mpas_log_write('--- end subroutine sf_noahmp_deallocate:') + + end subroutine sf_noahmp_deallocate + +!================================================================================================================= + end module mpas_atmphys_lsm_noahmpfinalize +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F new file mode 100644 index 0000000000..da1cead2c0 --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_noahmpinit.F @@ -0,0 +1,501 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and 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_lsm_noahmpinit + use mpas_log + use mpas_pool_routines + + use mpas_atmphys_utilities,only: physics_error_fatal + use mpas_atmphys_vars,only : mpas_noahmp + + use NoahmpInitMainMod,only : NoahmpInitMain + use NoahmpIOVarInitMod,only: NoahmpIOVarInitDefault + use NoahmpIOVarType + use NoahmpReadNamelistMod + use NoahmpReadTableMod,only: NoahmpReadTable + + + private + public:: init_lsm_noahmp + + + contains + + +!================================================================================================================= + subroutine init_lsm_noahmp(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + +!--- inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + +!--- local variables and arrays: + character(len=StrKIND),pointer:: mminlu + + integer:: ns + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine init_lsm_noahmp:') + + +!--- initialize dimensions: + call noahmp_read_dimensions(mesh) + + +!--- initialize namelist options: + call noahmp_read_namelist(configs) + + +!--- allocate Noahmp arrays: +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine NoahmpIOVarInitDefault:') + call NoahmpIOVarInitDefault(mpas_noahmp) +!call mpas_log_write('--- end subroutine NoahmpIOVarInitDefault:') + + +!--- read NoahmpTable.TBL: + call mpas_pool_get_array(sfc_input,'mminlu',mminlu) + mpas_noahmp%llanduse = mminlu + +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine NoahmpReadTable:') + call NoahmpReadTable(mpas_noahmp) +!call mpas_log_write('--- isbarren_table = $i',intArgs=(/mpas_noahmp%isbarren_table/)) +!call mpas_log_write('--- isice_table = $i',intArgs=(/mpas_noahmp%isice_table/) ) +!call mpas_log_write('--- iswater_table = $i',intArgs=(/mpas_noahmp%iswater_table/) ) +!call mpas_log_write('--- isurban_table = $i',intArgs=(/mpas_noahmp%isurban_table/) ) +!call mpas_log_write('--- urbtype_beg = $i',intArgs=(/mpas_noahmp%urbtype_beg/) ) +!call mpas_log_write('--- slcats_table = $i',intArgs=(/mpas_noahmp%slcats_table/) ) +!call mpas_log_write(' ') +!do ns = 1,mpas_noahmp%slcats_table +! call mpas_log_write('--- BEXP,SMCMAX,PSISAT: $i $r $r $r',intArgs=(/ns/),realArgs= & +! (/mpas_noahmp%bexp_table(ns),mpas_noahmp%smcmax_table(ns),mpas_noahmp%psisat_table(ns)/)) +!enddo +!call mpas_log_write('--- end subroutine NoahmpReadTable:') + + +!--- initialize noahmp: + call noahmp_init(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) + + +!call mpas_log_write('--- end subroutine init_lsm_noahmp:') +!call mpas_log_write(' ') + + end subroutine init_lsm_noahmp + +!================================================================================================================= + subroutine noahmp_read_dimensions(mesh) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: mesh + +!--- local variables and pointers: + integer,pointer:: nCellsSolve,nVertLevels + integer,pointer:: nSoilLevels,nSnowLevels + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine noahmp_read_dimensions:') + + + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nVertLevels',nVertLevels) + call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) + call mpas_pool_get_dimension(mesh,'nSnowLevels',nSnowLevels) + + mpas_noahmp%its = 1 + mpas_noahmp%ite = nCellsSolve + mpas_noahmp%kts = 1 + mpas_noahmp%kte = nVertLevels + + mpas_noahmp%nsoil = nSoilLevels + mpas_noahmp%nsnow = nSnowLevels + +!call mpas_log_write(' its = $i ite = $i', intArgs=(/mpas_noahmp%its,mpas_noahmp%ite/)) +!call mpas_log_write(' kts = $i kte = $i', intArgs=(/mpas_noahmp%kts,mpas_noahmp%kte/)) +!call mpas_log_write(' ') +!call mpas_log_write(' nSoilLevels = $i',intArgs=(/mpas_noahmp%nsoil/)) +!call mpas_log_write(' nSnowLevels = $i',intArgs=(/mpas_noahmp%nsnow/)) + + +!call mpas_log_write('--- end subroutine noahmp_read_dimensions:') + + end subroutine noahmp_read_dimensions + +!================================================================================================================= + subroutine noahmp_read_namelist(configs) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + + +!--- local variables and pointers: + integer,pointer:: iopt_dveg , iopt_crs , iopt_btr , iopt_runsrf , iopt_runsub , iopt_sfc , iopt_frz , & + iopt_inf , iopt_rad , iopt_alb , iopt_snf , iopt_tksno , iopt_tbot , iopt_stc , & + iopt_gla , iopt_rsf , iopt_soil , iopt_pedo , iopt_crop , iopt_irr , iopt_irrm , & + iopt_infdv , iopt_tdrn + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine noahmp_read_namelist:') + + call mpas_pool_get_config(configs,'config_noahmp_iopt_dveg' ,iopt_dveg ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_crs' ,iopt_crs ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_btr' ,iopt_btr ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_runsrf',iopt_runsrf) + call mpas_pool_get_config(configs,'config_noahmp_iopt_runsub',iopt_runsub) + call mpas_pool_get_config(configs,'config_noahmp_iopt_sfc' ,iopt_sfc ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_frz' ,iopt_frz ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_inf' ,iopt_inf ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_rad' ,iopt_rad ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_alb' ,iopt_alb ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_snf' ,iopt_snf ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_tksno' ,iopt_tksno ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_tbot' ,iopt_tbot ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_stc' ,iopt_stc ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_gla' ,iopt_gla ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_rsf' ,iopt_rsf ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_soil' ,iopt_soil ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_pedo' ,iopt_pedo ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_crop' ,iopt_crop ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_irr' ,iopt_irr ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_irrm' ,iopt_irrm ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_infdv' ,iopt_infdv ) + call mpas_pool_get_config(configs,'config_noahmp_iopt_tdrn' ,iopt_tdrn ) + + mpas_noahmp%iopt_dveg = iopt_dveg + mpas_noahmp%iopt_crs = iopt_crs + mpas_noahmp%iopt_btr = iopt_btr + mpas_noahmp%iopt_runsrf = iopt_runsrf + mpas_noahmp%iopt_runsub = iopt_runsub + mpas_noahmp%iopt_sfc = iopt_sfc + mpas_noahmp%iopt_frz = iopt_frz + mpas_noahmp%iopt_inf = iopt_inf + mpas_noahmp%iopt_rad = iopt_rad + mpas_noahmp%iopt_alb = iopt_alb + mpas_noahmp%iopt_snf = iopt_snf + mpas_noahmp%iopt_tksno = iopt_tksno + mpas_noahmp%iopt_tbot = iopt_tbot + mpas_noahmp%iopt_stc = iopt_stc + mpas_noahmp%iopt_gla = iopt_gla + mpas_noahmp%iopt_rsf = iopt_rsf + mpas_noahmp%iopt_soil = iopt_soil + mpas_noahmp%iopt_pedo = iopt_pedo + mpas_noahmp%iopt_crop = iopt_crop + mpas_noahmp%iopt_irr = iopt_irr + mpas_noahmp%iopt_irrm = iopt_irrm + mpas_noahmp%iopt_infdv = iopt_infdv + mpas_noahmp%iopt_tdrn = iopt_tdrn + +!--- check options that are not available in MPAS: + if(iopt_soil == 4) call physics_error_fatal("NOAHmp: iopt_soil = 4 is not an available option") + if(iopt_crop > 0 ) call physics_error_fatal("NOAHmp: crop model is not an available option. set iopt_crop = 0") + if(iopt_irr > 0 ) call physics_error_fatal("NOAHmp: irrigation is not an available option. set iopt_irr = 0" ) + if(iopt_irrm > 0 ) call physics_error_fatal("NOAHmp: irrigation is not an available option. set iopt_irrm = 0") + if(iopt_tdrn > 0 ) call physics_error_fatal("NOAHmp: drainage is not an available option. set iopt_tdrn = 0" ) + +!call mpas_log_write('--- end subroutine noahmp_read_namelist:') + + end subroutine noahmp_read_namelist + +!================================================================================================================= + subroutine noahmp_init(configs,mesh,diag_physics,diag_physics_noahmp,output_noahmp,sfc_input) +!================================================================================================================= + +!--- input arguments: + type(mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: mesh + +!--- inout arguments: + type(mpas_pool_type),intent(inout):: diag_physics + type(mpas_pool_type),intent(inout):: diag_physics_noahmp + type(mpas_pool_type),intent(inout):: output_noahmp + type(mpas_pool_type),intent(inout):: sfc_input + +!local pointers: + logical,pointer:: urban_physics + + integer,pointer:: nsoilcomps + integer,dimension(:),pointer:: isltyp,ivgtyp + integer,dimension(:),pointer:: isnowxy + integer,dimension(:),pointer:: irnumsi,irnummi,irnumfi + + real(kind=RKIND),pointer:: dt + + real(kind=RKIND),dimension(:),pointer:: soilcl1,soilcl2,soilcl3,soilcl4 + real(kind=RKIND),dimension(:,:),pointer:: soilcomp + + real(kind=RKIND),dimension(:),pointer:: areaCell,latCell,lonCell + real(kind=RKIND),dimension(:),pointer:: canwat,lai,skintemp,snow,snowc,snowh,tmn,xice,xland + real(kind=RKIND),dimension(:),pointer:: alboldxy,canicexy,canliqxy,chxy,cmxy,eahxy,fastcpxy,fwetxy,gddxy, & + grainxy,lfmassxy,qrainxy,qsnowxy,rtmassxy,sneqvoxy,stblcpxy,stmassxy, & + tahxy,tgxy,tvxy,xsaixy,waxy,woodxy,wslakexy,wtxy,zwtxy + real(kind=RKIND),dimension(:),pointer:: irwatsi,ireloss,irrsplh,irwatmi,irmivol,irwatfi,irfivol + real(kind=RKIND),dimension(:),pointer:: qtdrain,t2mbxy,t2mvxy + + real(kind=RKIND),dimension(:,:),pointer:: dzs,sh2o,smois,tslb + real(kind=RKIND),dimension(:,:),pointer:: snicexy,snliqxy,tsnoxy,zsnsoxy + +!local variables and pointers: + logical,pointer:: do_restart + logical,parameter:: fndsnowh = .true. + integer:: i,its,ite,ns,nsoil,nsnow,nzsnow + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine noahmp_init:') + + +!--- initialization of local dimensions: + its = mpas_noahmp%its + ite = mpas_noahmp%ite + nsoil = mpas_noahmp%nsoil + nsnow = mpas_noahmp%nsnow + nzsnow = nsnow + nsoil + + +!--- initialization of Noah-MP run parameters: + call mpas_pool_get_config(configs,'config_do_restart',do_restart) + call mpas_pool_get_config(configs,'config_urban_physics',urban_physics) + call mpas_pool_get_config(configs,'config_dt',dt) + + mpas_noahmp%restart_flag = do_restart + mpas_noahmp%sf_urban_physics = 0 + if(urban_physics) mpas_noahmp%sf_urban_physics = 1 + + mpas_noahmp%fndsnowh = fndsnowh + mpas_noahmp%dtbl = dt + + +!--- initialization of Noah-MP mesh variables: + call mpas_pool_get_dimension(mesh,'nSoilComps',nsoilcomps) + + call mpas_pool_get_array(mesh,'areaCell',areaCell) + call mpas_pool_get_array(mesh,'latCell' ,latCell ) + call mpas_pool_get_array(mesh,'lonCell' ,lonCell ) + call mpas_pool_get_array(mesh,'soilcomp',soilcomp) + call mpas_pool_get_array(mesh,'soilcl1' ,soilcl1 ) + call mpas_pool_get_array(mesh,'soilcl2' ,soilcl2 ) + call mpas_pool_get_array(mesh,'soilcl3' ,soilcl3 ) + call mpas_pool_get_array(mesh,'soilcl4' ,soilcl4 ) + + do i = its,ite + mpas_noahmp%areaxy(i) = areaCell(i) + mpas_noahmp%xlat(i) = latCell(i) + mpas_noahmp%xlong(i) = lonCell(i) + enddo + if(mpas_noahmp%iopt_soil > 1) then + do i = its,ite + mpas_noahmp%soilcl1(i) = soilcl1(i) + mpas_noahmp%soilcl2(i) = soilcl2(i) + mpas_noahmp%soilcl3(i) = soilcl3(i) + mpas_noahmp%soilcl4(i) = soilcl4(i) + do ns = 1,nsoilcomps + mpas_noahmp%soilcomp(i,ns) = soilcomp(ns,i) + enddo + enddo + endif + + +!--- initialization of time-invariant surface variables needed in subroutine NoahmpInitMain: + call mpas_pool_get_array(sfc_input,'dzs' ,dzs ) + call mpas_pool_get_array(sfc_input,'isltyp',isltyp) + call mpas_pool_get_array(sfc_input,'ivgtyp',ivgtyp) + + do i = its, ite + mpas_noahmp%isltyp(i) = isltyp(i) + mpas_noahmp%ivgtyp(i) = ivgtyp(i) + enddo + do ns = 1, nsoil + mpas_noahmp%dzs(ns) = dzs(ns,its) + enddo + + + if(mpas_noahmp%restart_flag) return + +!--- initialization of time-varying variables needed in subroutine NoahmpInitMain: + call mpas_pool_get_array(sfc_input,'skintemp',skintemp) + 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,'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,'smois' ,smois ) + call mpas_pool_get_array(sfc_input,'tslb' ,tslb ) + + call mpas_pool_get_array(diag_physics,'canwat',canwat) + call mpas_pool_get_array(diag_physics,'lai',lai) + + call mpas_pool_get_array(diag_physics_noahmp,'alboldxy',alboldxy) + call mpas_pool_get_array(diag_physics_noahmp,'canicexy',canicexy) + call mpas_pool_get_array(diag_physics_noahmp,'canliqxy',canliqxy) + call mpas_pool_get_array(diag_physics_noahmp,'chxy' ,chxy ) + call mpas_pool_get_array(diag_physics_noahmp,'cmxy' ,cmxy ) + call mpas_pool_get_array(diag_physics_noahmp,'eahxy' ,eahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'fastcpxy',fastcpxy) + call mpas_pool_get_array(diag_physics_noahmp,'fwetxy' ,fwetxy ) + call mpas_pool_get_array(diag_physics_noahmp,'gddxy' ,gddxy ) + call mpas_pool_get_array(diag_physics_noahmp,'grainxy' ,grainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'lfmassxy',lfmassxy) + call mpas_pool_get_array(diag_physics_noahmp,'qrainxy' ,qrainxy ) + call mpas_pool_get_array(diag_physics_noahmp,'qsnowxy' ,qsnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'rtmassxy',rtmassxy) + call mpas_pool_get_array(diag_physics_noahmp,'sneqvoxy',sneqvoxy) + call mpas_pool_get_array(diag_physics_noahmp,'stblcpxy',stblcpxy) + call mpas_pool_get_array(diag_physics_noahmp,'stmassxy',stmassxy) + call mpas_pool_get_array(diag_physics_noahmp,'tahxy' ,tahxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tgxy' ,tgxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tvxy' ,tvxy ) + call mpas_pool_get_array(diag_physics_noahmp,'waxy' ,waxy ) + call mpas_pool_get_array(diag_physics_noahmp,'woodxy' ,woodxy ) + call mpas_pool_get_array(diag_physics_noahmp,'wslakexy',wslakexy) + call mpas_pool_get_array(diag_physics_noahmp,'wtxy' ,wtxy ) + call mpas_pool_get_array(diag_physics_noahmp,'xsaixy' ,xsaixy ) + call mpas_pool_get_array(diag_physics_noahmp,'zwtxy' ,zwtxy ) + + call mpas_pool_get_array(diag_physics_noahmp,'irnumsi' ,irnumsi ) + call mpas_pool_get_array(diag_physics_noahmp,'irwatsi' ,irwatsi ) + call mpas_pool_get_array(diag_physics_noahmp,'ireloss' ,ireloss ) + call mpas_pool_get_array(diag_physics_noahmp,'irrsplh' ,irrsplh ) + call mpas_pool_get_array(diag_physics_noahmp,'irnummi' ,irnummi ) + call mpas_pool_get_array(diag_physics_noahmp,'irwatmi' ,irwatmi ) + call mpas_pool_get_array(diag_physics_noahmp,'irmivol' ,irmivol ) + call mpas_pool_get_array(diag_physics_noahmp,'irnumfi' ,irnumfi ) + call mpas_pool_get_array(diag_physics_noahmp,'irwatfi' ,irwatfi ) + call mpas_pool_get_array(diag_physics_noahmp,'irfivol', irfivol ) + + call mpas_pool_get_array(diag_physics_noahmp,'isnowxy' ,isnowxy ) + call mpas_pool_get_array(diag_physics_noahmp,'snicexy' ,snicexy ) + call mpas_pool_get_array(diag_physics_noahmp,'snliqxy' ,snliqxy ) + call mpas_pool_get_array(diag_physics_noahmp,'tsnoxy' ,tsnoxy ) + call mpas_pool_get_array(diag_physics_noahmp,'zsnsoxy' ,zsnsoxy ) + + call mpas_pool_get_array(output_noahmp,'t2mbxy',t2mbxy ) + call mpas_pool_get_array(output_noahmp,'t2mvxy',t2mvxy ) + call mpas_pool_get_array(output_noahmp,'qtdrain',qtdrain) + + + do i = its,ite + mpas_noahmp%tmn(i) = tmn(i) + mpas_noahmp%tsk(i) = skintemp(i) + mpas_noahmp%xice(i) = xice(i) + mpas_noahmp%xland(i) = xland(i) + mpas_noahmp%snow(i) = snow(i) + mpas_noahmp%snowh(i) = snowh(i) + + do ns = 1,nsoil + mpas_noahmp%sh2o(i,ns) = sh2o(ns,i) + mpas_noahmp%smois(i,ns) = smois(ns,i) + mpas_noahmp%tslb(i,ns) = tslb(ns,i) + enddo + enddo + + + call NoahmpInitMain(mpas_noahmp) + + +!--- update of all time-varying Noah-MP variables: + do i = its,ite + isnowxy(i) = mpas_noahmp%isnowxy(i) + snow(i) = mpas_noahmp%snow(i) ! in mm (check unit in noahmp driver). + snowh(i) = mpas_noahmp%snowh(i) ! in m (check unit in noahmp driver). + snowc(i) = 0._RKIND + if(snow(i) .gt. 0._RKIND) snowc(i) = 1. + + do ns = 1,nsoil + mpas_noahmp%sh2o(i,ns) = sh2o(ns,i) + mpas_noahmp%smois(i,ns) = smois(ns,i) + mpas_noahmp%tslb(i,ns) = tslb(ns,i) + enddo + enddo + + do ns = 1,nsnow + n = ns - nsnow + do i = its,ite + tsnoxy(ns,i) = mpas_noahmp%tsnoxy(i,n) + snicexy(ns,i) = mpas_noahmp%snicexy(i,n) + snliqxy(ns,i) = mpas_noahmp%snliqxy(i,n) + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + enddo + do ns = nsnow+1,nzsnow + n = ns - nsnow + do i = its,ite + zsnsoxy(ns,i) = mpas_noahmp%zsnsoxy(i,n) + enddo + enddo + + do i = its,ite + canwat(i) = mpas_noahmp%canwat(i) + lai(i) = mpas_noahmp%lai(i) + + isnowxy(i) = mpas_noahmp%isnowxy(i) + alboldxy(i) = mpas_noahmp%alboldxy(i) + canicexy(i) = mpas_noahmp%canicexy(i) + canliqxy(i) = mpas_noahmp%canliqxy(i) + chxy(i) = mpas_noahmp%chxy(i) + cmxy(i) = mpas_noahmp%cmxy(i) + eahxy(i) = mpas_noahmp%eahxy(i) + fastcpxy(i) = mpas_noahmp%fastcpxy(i) + fwetxy(i) = mpas_noahmp%fwetxy(i) + gddxy(i) = mpas_noahmp%gddxy(i) + grainxy(i) = mpas_noahmp%grainxy(i) + lfmassxy(i) = mpas_noahmp%lfmassxy(i) + qrainxy(i) = mpas_noahmp%qrainxy(i) + qsnowxy(i) = mpas_noahmp%qsnowxy(i) + rtmassxy(i) = mpas_noahmp%rtmassxy(i) + sneqvoxy(i) = mpas_noahmp%sneqvoxy(i) + stblcpxy(i) = mpas_noahmp%stblcpxy(i) + stmassxy(i) = mpas_noahmp%stmassxy(i) + tahxy(i) = mpas_noahmp%tahxy(i) + tgxy(i) = mpas_noahmp%tgxy(i) + tvxy(i) = mpas_noahmp%tvxy(i) + waxy(i) = mpas_noahmp%waxy(i) + woodxy(i) = mpas_noahmp%woodxy(i) + wslakexy(i) = mpas_noahmp%wslakexy(i) + wtxy(i) = mpas_noahmp%wtxy(i) + xsaixy(i) = mpas_noahmp%xsaixy(i) + zwtxy(i) = mpas_noahmp%zwtxy(i) + + qtdrain(i) = mpas_noahmp%qtdrain(i) + t2mbxy(i) = mpas_noahmp%t2mbxy(i) + t2mvxy(i) = mpas_noahmp%t2mvxy(i) + enddo + + do i = its, ite + irnumsi(i) = mpas_noahmp%irnumsi(i) + irwatsi(i) = mpas_noahmp%irwatsi(i) + ireloss(i) = mpas_noahmp%ireloss(i) + irrsplh(i) = mpas_noahmp%irrsplh(i) + irnummi(i) = mpas_noahmp%irnummi(i) + irwatmi(i) = mpas_noahmp%irwatmi(i) + irmivol(i) = mpas_noahmp%irmivol(i) + irnumfi(i) = mpas_noahmp%irnumfi(i) + irwatfi(i) = mpas_noahmp%irwatfi(i) + irfivol(i) = mpas_noahmp%irfivol(i) + enddo + + +!call mpas_log_write('--- end subroutine noahmp_init:') + + end subroutine noahmp_init + +!================================================================================================================= + end module mpas_atmphys_lsm_noahmpinit +!================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_lsm_shared.F b/src/core_atmosphere/physics/mpas_atmphys_lsm_shared.F new file mode 100644 index 0000000000..af5a1a436a --- /dev/null +++ b/src/core_atmosphere/physics/mpas_atmphys_lsm_shared.F @@ -0,0 +1,65 @@ +! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) +! and 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_lsm_shared + use mpas_kind_types + + + implicit none + private + public:: correct_tsk_over_seaice + + + contains + + +!================================================================================================================= + 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_lsm_shared +!================================================================================================================= + + + + diff --git a/src/core_atmosphere/physics/mpas_atmphys_manager.F b/src/core_atmosphere/physics/mpas_atmphys_manager.F index fe8ee5c27c..ef0f3dc154 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_manager.F +++ b/src/core_atmosphere/physics/mpas_atmphys_manager.F @@ -23,6 +23,8 @@ module mpas_atmphys_manager public:: physics_timetracker,physics_run_init integer, public:: year !Current year. + integer, public:: month !Current month. + integer, public:: day !Current day of the month. integer, public:: julday !Initial Julian day. real(kind=RKIND), public:: curr_julday !Current Julian day (= 0.0 at 0Z on January 1st). real(kind=RKIND), public:: gmt !Greenwich mean time hour of model start (hr) @@ -124,6 +126,8 @@ module mpas_atmphys_manager ! * in subroutine physics_run_init, removed the initialization of the local variable microp_scheme. ! microp_scheme is no longer needed and can be replaced with config_microp_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * replaced the option "noah" with "sf_noah" to run the NOAH land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2022-02-18. contains @@ -181,12 +185,12 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) !call mpas_log_write('--- enter subroutine physics_timetracker: itimestep = $i', intArgs=(/itimestep/)) call mpas_pool_get_config(domain%blocklist%configs,'config_convection_scheme',config_convection_scheme) - call mpas_pool_get_config(domain%blocklist%configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) - call mpas_pool_get_config(domain%blocklist%configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radt_lw_scheme' ,config_radt_lw_scheme ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radt_sw_scheme' ,config_radt_sw_scheme ) - call mpas_pool_get_config(domain%blocklist%configs,'config_conv_interval' ,config_conv_interval ) - call mpas_pool_get_config(domain%blocklist%configs,'config_radtlw_interval' ,config_radtlw_interval ) - call mpas_pool_get_config(domain%blocklist%configs,'config_radtsw_interval' ,config_radtsw_interval ) + call mpas_pool_get_config(domain%blocklist%configs,'config_conv_interval' ,config_conv_interval ) + call mpas_pool_get_config(domain%blocklist%configs,'config_radtlw_interval',config_radtlw_interval) + call mpas_pool_get_config(domain%blocklist%configs,'config_radtsw_interval',config_radtsw_interval) call mpas_pool_get_config(domain%blocklist%configs,'config_frac_seaice' ,config_frac_seaice ) call mpas_pool_get_config(domain%blocklist%configs,'config_o3climatology' ,config_o3climatology ) @@ -198,7 +202,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) !update the current julian day and current year: currTime = mpas_get_clock_time(clock,MPAS_NOW,ierr) - call mpas_get_time(curr_time=currTime,dateTimeString=timeStamp,YYYY=yr,H=h,M=m, & + call mpas_get_time(curr_time=currTime,dateTimeString=timeStamp,YYYY=yr,MM=month,DD=day,H=h,M=m, & S=s,S_n=s_n,S_d=s_d,DoY=DoY,ierr=ierr) utc_h = real(h) + real(m) / 60.0 + real(s + s_n / s_d) / 3600.0 @@ -207,13 +211,13 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) julday = DoY curr_julday = real(julday-1) + utc_h / 24.0 LeapYear = isLeapYear(year) -! call mpas_log_write(' YEAR =$i', intArgs=(/year/)) -! call mpas_log_write(' JULDAY =$i', intArgs=(/julday/)) -! call mpas_log_write(' GMT =$r', realArgs=(/gmt/)) -! call mpas_log_write(' UTC_H =$r', realArgs=(/utc_h/)) -! call mpas_log_write(' CURR_JULDAY =$r', realArgs=(/curr_julday/)) -! call mpas_log_write(' LEAP_YEAR =$l', logicArgs=(/LeapYear/)) -! call mpas_log_write(' TIME STAMP ='//trim(timeStamp)) +!call mpas_log_write(' YEAR = $i', intArgs=(/year/)) +!call mpas_log_write(' JULDAY = $i', intArgs=(/julday/)) +!call mpas_log_write(' GMT = $r', realArgs=(/gmt/)) +!call mpas_log_write(' UTC_H = $r', realArgs=(/utc_h/)) +!call mpas_log_write(' CURR_JULDAY = $r', realArgs=(/curr_julday/)) +!call mpas_log_write(' LEAP_YEAR = $l', logicArgs=(/LeapYear/)) +!call mpas_log_write(' TIME STAMP = '//trim(timeStamp)) block => domain % blocklist do while(associated(block)) @@ -264,7 +268,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) elseif(config_radtlw_interval == "none") then l_radtlw = .true. endif - call mpas_log_write('--- time to run the LW radiation scheme L_RADLW =$l',logicArgs=(/l_radtlw/)) + call mpas_log_write('--- time to run the LW radiation scheme L_RADLW = $l',logicArgs=(/l_radtlw/)) endif if(trim(config_radt_sw_scheme) /= "off") then @@ -278,7 +282,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) elseif(config_radtsw_interval == "none") then l_radtsw = .true. endif - call mpas_log_write('--- time to run the SW radiation scheme L_RADSW =$l',logicArgs=(/l_radtsw/)) + call mpas_log_write('--- time to run the SW radiation scheme L_RADSW = $l',logicArgs=(/l_radtsw/)) endif !check to see if it is time to run the parameterization of convection: @@ -293,7 +297,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) elseif(config_conv_interval == "none") then l_conv = .true. endif - call mpas_log_write('--- time to run the convection scheme L_CONV =$l',logicArgs=(/l_conv/)) + call mpas_log_write('--- time to run the convection scheme L_CONV = $l',logicArgs=(/l_conv/)) endif !check to see if it is time to update ozone to the current julian day in the RRTMG radiation codes: @@ -332,7 +336,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_reset_clock_alarm(clock,camlwAlarmID,camlwTimeStep,ierr=ierr) l_camlw = .true. endif - call mpas_log_write('--- time to write local CAM arrays to MPAS arrays L_CAMLW =$l',logicArgs=(/l_camlw/)) + call mpas_log_write('--- time to write local CAM arrays to MPAS arrays L_CAMLW = $l',logicArgs=(/l_camlw/)) endif !check to see if it is time to apply limit to the accumulated rain due to cloud microphysics @@ -343,7 +347,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_reset_clock_alarm(clock,acrainAlarmID,acrainTimeStep,ierr=ierr) l_acrain = .true. endif - call mpas_log_write('--- time to apply limit to accumulated rainc and rainnc L_ACRAIN =$l',logicArgs=(/l_acrain/)) + call mpas_log_write('--- time to apply limit to accumulated rainc and rainnc L_ACRAIN = $l',logicArgs=(/l_acrain/)) endif !check to see if it is time to apply limit to the accumulated radiation diagnostics due to @@ -354,7 +358,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) call mpas_reset_clock_alarm(clock,acradtAlarmID,acradtTimeStep,ierr=ierr) l_acradt = .true. endif - call mpas_log_write('--- time to apply limit to accumulated radiation diags. L_ACRADT =$l',logicArgs=(/l_acradt/)) + call mpas_log_write('--- time to apply limit to accumulated radiation diags. L_ACRADT = $l',logicArgs=(/l_acradt/)) endif !check to see if it is time to calculate additional physics diagnostics: @@ -366,7 +370,7 @@ subroutine physics_timetracker(domain,dt,clock,itimestep,xtime_s) if (mpas_is_alarm_ringing(clock,diagAlarmID,interval=dtInterval,ierr=ierr)) then l_diags = .true. end if - call mpas_log_write('--- time to calculate additional physics_diagnostics =$l',logicArgs=(/l_diags/)) + call mpas_log_write('--- time to calculate additional physics_diagnostics = $l',logicArgs=(/l_diags/)) end subroutine physics_timetracker @@ -382,18 +386,18 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) type (MPAS_streamManager_type), intent(inout) :: stream_manager !local pointers: - character(len=StrKIND),pointer:: config_convection_scheme, & - config_lsm_scheme, & - config_microp_scheme, & - config_radt_lw_scheme, & + character(len=StrKIND),pointer:: config_convection_scheme, & + config_lsm_scheme, & + config_microp_scheme, & + config_radt_lw_scheme, & config_radt_sw_scheme - character(len=StrKIND),pointer:: config_conv_interval, & - config_pbl_interval, & - config_radtlw_interval, & - config_radtsw_interval, & - config_bucket_update, & - config_camrad_abs_update, & + character(len=StrKIND),pointer:: config_conv_interval, & + config_pbl_interval, & + config_radtlw_interval, & + config_radtsw_interval, & + config_bucket_update, & + config_camrad_abs_update, & config_greeness_update logical,pointer:: config_sst_update @@ -640,10 +644,11 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) end if endif - call mpas_log_write(' DT_RADTLW =$r', realArgs=(/dt_radtlw/)) - call mpas_log_write(' DT_RADTSW =$r', realArgs=(/dt_radtsw/)) - call mpas_log_write(' DT_CU =$r', realArgs=(/dt_cu/)) - call mpas_log_write(' DT_PBL =$r', realArgs=(/dt_pbl/)) + call mpas_log_write(' ') + call mpas_log_write('DT_RADTLW = $r',realArgs=(/dt_radtlw/)) + call mpas_log_write('DT_RADTSW = $r',realArgs=(/dt_radtsw/)) + call mpas_log_write('DT_CU = $r',realArgs=(/dt_cu/)) + call mpas_log_write('DT_PBL = $r',realArgs=(/dt_pbl/)) !initialization of physics dimensions to mimic a rectangular grid: ims=1 ; ime = nCellsSolve @@ -658,21 +663,22 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) jts=jms ; jte = jme kts=kms ; kte = kme-1 - call mpas_log_write(' IMS =$i IME =$i', intArgs=(/ims,ime/)) - call mpas_log_write(' JMS =$i JME =$i', intArgs=(/jms,jme/)) - call mpas_log_write(' KMS =$i KME =$i', intArgs=(/kms,kme/)) - call mpas_log_write(' IDS =$i IDE =$i', intArgs=(/ids,ide/)) - call mpas_log_write(' JDS =$i JDE =$i', intArgs=(/jds,jde/)) - call mpas_log_write(' KDS =$i KDE =$i', intArgs=(/kds,kde/)) - call mpas_log_write(' ITS =$i ITE =$i', intArgs=(/its,ite/)) - call mpas_log_write(' JTS =$i JTE =$i', intArgs=(/jts,jte/)) - call mpas_log_write(' KTS =$i KTE =$i', intArgs=(/kts,kte/)) + call mpas_log_write(' ') + call mpas_log_write('IMS = $i IME = $i',intArgs=(/ims,ime/)) + call mpas_log_write('JMS = $i JME = $i',intArgs=(/jms,jme/)) + call mpas_log_write('KMS = $i KME = $i',intArgs=(/kms,kme/)) + call mpas_log_write('IDS = $i IDE = $i',intArgs=(/ids,ide/)) + call mpas_log_write('JDS = $i JDE = $i',intArgs=(/jds,jde/)) + call mpas_log_write('KDS = $i KDE = $i',intArgs=(/kds,kde/)) + call mpas_log_write('ITS = $i ITE = $i',intArgs=(/its,ite/)) + call mpas_log_write('JTS = $i JTE = $i',intArgs=(/jts,jte/)) + call mpas_log_write('KTS = $i KTE = $i',intArgs=(/kts,kte/)) !initialization local physics variables: num_months = nMonths num_soils = nSoilLevels - if(trim(config_lsm_scheme) .eq. "noah") sf_surface_physics = 2 + if(trim(config_lsm_scheme) .eq. "sf_noah") sf_surface_physics = 2 !initialization of local physics time-steps: !... dynamics: @@ -680,12 +686,14 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) !... cloud microphysics: dt_microp = dt_dyn n_microp = 1 - if(trim(config_microp_scheme)=='mp_thompson') then + if(trim(config_microp_scheme)=='mp_thompson' .or. & + trim(config_microp_scheme)=='mp_thompson_aerosols') then dt_microp = 90._RKIND n_microp = max(nint(dt_dyn/dt_microp),1) dt_microp = dt_dyn / n_microp if(dt_dyn <= dt_microp) dt_microp = dt_dyn endif + call mpas_log_write(' ') call mpas_log_write('--- specifics on cloud microphysics option microp_scheme = '//trim(config_microp_scheme)) call mpas_log_write('--- dt_microp = $r', realArgs=(/dt_microp/)) call mpas_log_write('--- n_microp = $i', intArgs=(/n_microp/)) @@ -741,7 +749,8 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) has_reqi = 0 has_reqs = 0 if(config_microp_re) then - if(trim(config_microp_scheme)=='mp_thompson' .or. & + if(trim(config_microp_scheme)=='mp_thompson' .or. & + trim(config_microp_scheme)=='mp_thompson_aerosols' .or. & trim(config_microp_scheme)=='mp_wsm6') then if(trim(config_radt_lw_scheme)=='rrtmg_lw' .and. trim(config_radt_sw_scheme)=='rrtmg_sw') then has_reqc = 1 @@ -753,6 +762,7 @@ subroutine physics_run_init(configs,mesh,state,clock,stream_manager) call mpas_log_write('--- has_reqc = $i', intArgs=(/has_reqc/)) call mpas_log_write('--- has_reqi = $i', intArgs=(/has_reqi/)) call mpas_log_write('--- has_reqs = $i', intArgs=(/has_reqs/)) + call mpas_log_write(' ') end subroutine physics_run_init diff --git a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F index 04d4f7f5bc..2c0497e168 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F +++ b/src/core_atmosphere/physics/mpas_atmphys_o3climatology.F @@ -12,6 +12,7 @@ module mpas_atmphys_o3climatology use mpas_atmphys_date_time use mpas_atmphys_constants use mpas_atmphys_utilities + use mpas_io_units, only: mpas_new_unit, mpas_release_unit !wrf physics: use module_ra_cam_support, only: r8, getfactors @@ -74,9 +75,7 @@ subroutine init_o3climatology(mesh,atm_input) real(kind=RKIND),dimension(:,:,:),pointer:: ozmixm !local variables: - integer,parameter:: pin_unit = 27 - integer,parameter:: lat_unit = 28 - integer,parameter:: oz_unit = 29 + integer :: pin_unit, lat_unit, oz_unit integer,parameter:: open_ok = 0 integer:: i,i1,i2,istat,k,j,m @@ -100,6 +99,7 @@ subroutine init_o3climatology(mesh,atm_input) call mpas_pool_get_array(mesh,'lonCell',lonCell) !-- read in ozone pressure data: + call mpas_new_unit(pin_unit) open(pin_unit,file='OZONE_PLEV.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & @@ -108,8 +108,10 @@ subroutine init_o3climatology(mesh,atm_input) read(pin_unit,*) pin(k) enddo close(pin_unit) + call mpas_release_unit(pin_unit) !-- read in ozone lat data: + call mpas_new_unit(lat_unit) open(lat_unit, file='OZONE_LAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & @@ -119,8 +121,10 @@ subroutine init_o3climatology(mesh,atm_input) ! call mpas_log_write('$i $r', intArgs=(/j/), realArgs=(/lat_ozone(j)/)) enddo close(lat_unit) + call mpas_release_unit(lat_unit) !-- read in ozone data: + call mpas_new_unit(oz_unit) open(oz_unit,file='OZONE_DAT.TBL',action='READ',status='OLD',iostat=istat) if(istat /= open_ok) & call physics_error_fatal('subroutine oznini: ' // & @@ -137,6 +141,7 @@ subroutine init_o3climatology(mesh,atm_input) enddo enddo close(oz_unit) + call mpas_release_unit(oz_unit) !INTERPOLATION OF INPUT OZONE DATA TO MPAS GRID: !call mpas_log_write('max latCell=$r', realArgs=(/maxval(latCell)/degrad/)) diff --git a/src/core_atmosphere/physics/mpas_atmphys_packages.F b/src/core_atmosphere/physics/mpas_atmphys_packages.F index f85d955400..5d32cb297e 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_packages.F +++ b/src/core_atmosphere/physics/mpas_atmphys_packages.F @@ -36,9 +36,11 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) character(len=StrKIND),pointer:: config_microp_scheme 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 + character(len=StrKIND),pointer:: config_lsm_scheme + logical,pointer:: mp_kessler_in,mp_thompson_in,mp_thompson_aers_in,mp_wsm6_in + logical,pointer:: cu_grell_freitas_in,cu_kain_fritsch_in,cu_ntiedtke_in logical,pointer:: bl_mynn_in,bl_ysu_in + logical,pointer:: sf_noahmp_in integer :: ierr @@ -61,11 +63,15 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) nullify(mp_thompson_in) call mpas_pool_get_package(packages,'mp_thompson_inActive',mp_thompson_in) + nullify(mp_thompson_aers_in) + call mpas_pool_get_package(packages,'mp_thompson_aers_inActive',mp_thompson_aers_in) + nullify(mp_wsm6_in) call mpas_pool_get_package(packages,'mp_wsm6_inActive',mp_wsm6_in) - if(.not.associated(mp_kessler_in) .or. & - .not.associated(mp_thompson_in) .or. & + if(.not.associated(mp_kessler_in ) .or. & + .not.associated(mp_thompson_in ) .or. & + .not.associated(mp_thompson_aers_in) .or. & .not.associated(mp_wsm6_in)) then call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) call mpas_log_write('* Error while setting up packages for cloud microphysics options in atmosphere core.',messageType=MPAS_LOG_ERR) @@ -74,20 +80,24 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) return endif - mp_kessler_in = .false. - mp_thompson_in = .false. - mp_wsm6_in = .false. + mp_kessler_in = .false. + mp_thompson_in = .false. + mp_thompson_aers_in = .false. + mp_wsm6_in = .false. if(config_microp_scheme == 'mp_kessler') then mp_kessler_in = .true. elseif(config_microp_scheme == 'mp_thompson') then mp_thompson_in = .true. + elseif(config_microp_scheme == 'mp_thompson_aerosols') then + mp_thompson_aers_in = .true. elseif(config_microp_scheme == 'mp_wsm6') then mp_wsm6_in = .true. endif call mpas_log_write(' mp_kessler_in = $l', logicArgs=(/mp_kessler_in/)) call mpas_log_write(' mp_thompson_in = $l', logicArgs=(/mp_thompson_in/)) + call mpas_log_write(' mp_thompson_aers_in = $l', logicArgs=(/mp_thompson_aers_in/)) call mpas_log_write(' mp_wsm6_in = $l', logicArgs=(/mp_wsm6_in/)) !--- initialization of all packages for parameterizations of convection: @@ -100,12 +110,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 +125,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 +133,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: @@ -162,6 +172,29 @@ function atmphys_setup_packages(configs,packages,iocontext) result(ierr) call mpas_log_write(' bl_ysu_in = $l', logicArgs=(/bl_ysu_in/)) call mpas_log_write('') +!--- initialization of all packages for parameterizations of land surface processes: + + call mpas_pool_get_config(configs,'config_lsm_scheme',config_lsm_scheme) + + nullify(sf_noahmp_in) + call mpas_pool_get_package(packages,'sf_noahmp_inActive',sf_noahmp_in) + + if(.not.associated(sf_noahmp_in)) then + call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) + call mpas_log_write('* Error while setting up packages for land surface options in atmosphere core.' , messageType=MPAS_LOG_ERR) + call mpas_log_write('====================================================================================',messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + if(config_lsm_scheme=='sf_noahmp') then + sf_noahmp_in = .true. + endif + + call mpas_log_write(' sf_noahmp_in = $l', logicArgs=(/sf_noahmp_in/)) + call mpas_log_write('') + + end function atmphys_setup_packages !================================================================================================================= diff --git a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F index 2ba79151f1..3e546e2a3a 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_lwinit.F @@ -15,6 +15,7 @@ module mpas_atmphys_rrtmg_lwinit use mpas_atmphys_constants use mpas_atmphys_utilities use mpas_log, only : mpas_log_write + use mpas_io_units !wrf physics use module_ra_rrtmg_lw @@ -71,16 +72,9 @@ subroutine rrtmg_lwlookuptable(dminfo) !----------------------------------------------------------------------------------------------------------------- !get a unit to open init file: - istat = -999 if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened ) then - rrtmg_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(rrtmg_unit, unformatted = .true.) + if(rrtmg_unit < 0) & call physics_error_fatal('module_ra_rrtmg_lw: rrtm_lwlookuptable: Can not '// & 'find unused fortran unit to read in lookup table.' ) @@ -121,7 +115,10 @@ subroutine rrtmg_lwlookuptable(dminfo) call lw_kgb15(rrtmg_unit,dminfo) call lw_kgb16(rrtmg_unit,dminfo) - if(dminfo % my_proc_id == IO_NODE) close(rrtmg_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(rrtmg_unit) + call mpas_release_unit(rrtmg_unit) + end if end subroutine rrtmg_lwlookuptable diff --git a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F index 7811454bd2..7ad8284e41 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F +++ b/src/core_atmosphere/physics/mpas_atmphys_rrtmg_swinit.F @@ -17,6 +17,7 @@ module mpas_atmphys_rrtmg_swinit use mpas_atmphys_constants use mpas_atmphys_utilities use mpas_log, only : mpas_log_write + use mpas_io_units !wrf physics use module_ra_rrtmg_sw @@ -73,14 +74,8 @@ subroutine rrtmg_swlookuptable(dminfo) !get a unit to open init file: if(dminfo % my_proc_id == IO_NODE) then - do i = 10,99 - inquire(i,opened = opened,iostat=istat) - if(.not. opened) then - rrtmg_unit = i - exit - endif - enddo - if(istat /= 0) & + call mpas_new_unit(rrtmg_unit, unformatted = .true.) + if(rrtmg_unit < 0) & call physics_error_fatal('module_ra_rrtmg_sw: rrtm_swlookuptable: Can not '// & 'find unused fortran unit to read in lookup table.' ) endif @@ -120,7 +115,10 @@ subroutine rrtmg_swlookuptable(dminfo) call sw_kgb28(rrtmg_unit,dminfo) call sw_kgb29(rrtmg_unit,dminfo) - if(dminfo % my_proc_id == IO_NODE) close(rrtmg_unit) + if(dminfo % my_proc_id == IO_NODE) then + close(rrtmg_unit) + call mpas_release_unit(rrtmg_unit) + end if end subroutine rrtmg_swlookuptable diff --git a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F index c7baeb213a..284b072851 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_todynamics.F +++ b/src/core_atmosphere/physics/mpas_atmphys_todynamics.F @@ -10,6 +10,7 @@ module mpas_atmphys_todynamics use mpas_kind_types use mpas_pool_routines use mpas_dmpar + use mpas_atm_dimensions use mpas_atmphys_constants, only: R_d,R_v,degrad @@ -21,416 +22,424 @@ module mpas_atmphys_todynamics !Interface between the physics parameterizations and the non-hydrostatic dynamical core. !Laura D. Fowler (send comments to laura@ucar.edu). !2013-05-01. -! -! + + ! subroutines in mpas_atmphys_todynamics: ! --------------------------------------- -! physics_get_tend: add and mass-weigh tendencies before being added to dynamics tendencies. -! tend_toEdges : interpolate wind-tendencies from centers to edges of grid-cells. +! physics_get_tend : intermediate subroutine between the dynamical core and calculation of the total +! physics tendencies. +! physics_get_tend_work: add and mass-weigh physics tendencies before being added to dynamics tendencies. +! tend_toEdges : interpolate wind-tendencies from centers to edges of grid-cells. ! ! add-ons and modifications to sourcecode: ! ---------------------------------------- -! * added calculation of the advective tendency of the potential temperature due to horizontal -! and vertical advection, and horizontal mixing (diffusion). -! Laura D. Fowler (birch.mmm.ucar.edu) / 2013-11-19. -! * throughout the sourcecode, replaced all "var_struct" defined arrays by local pointers. -! Laura D. Fowler (laura@ucar.edu) / 2014-04-22. -! * modified sourcecode to use pools. -! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. -! * renamed config_conv_deep_scheme to config_convection_scheme. -! 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". -! Laura D. Fowler (laura@ucar.edu) / 2016-03-24. -! * added the calculation of rthdynten which is the tendency of potential temperature due to horizontal and -! vertical advections needed in the Grell-Freitas scheme. -! Laura D. Fowler (laura@ucar.edu) / 2016-03-30. -! * 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. -! * in subroutine physics_get_tend_work, added the option cu_ntiedtke in the calculation of rucuten_Edge. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-28. +! * cleaned-up subroutines physics_get_tend and physics_get_tend_work. +! Laura D. Fowler (laura@ucar.edu) / 2018-01-23. +! * removed the option bl_mynn_wrf390. +! Laura D. Fowler (laura@ucar.edu) / 2018-01-24. +! * added tendencies of cloud liquid water number concentration, and water-friendly and ice-friendly aerosol +! number concentrations due to PBL processes. +! Laura D. Fowler (laura@ucar.edu) / 2024-05-16. + +! +! 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 contains !================================================================================================================= - subroutine physics_get_tend( block, mesh, state, diag, tend, tend_physics, configs, rk_step, dynamics_substep, & - tend_ru_physics, tend_rtheta_physics, tend_rho_physics ) + subroutine physics_get_tend(block,mesh,state,diag,tend,tend_physics,configs,rk_step,dynamics_substep, & + tend_ru_physics,tend_rtheta_physics,tend_rho_physics,exchange_halo_group) !================================================================================================================= - - use mpas_atm_dimensions !input variables: type(block_type),intent(in),target:: block type(mpas_pool_type),intent(in):: mesh type(mpas_pool_type),intent(in):: state type(mpas_pool_type),intent(in):: configs - integer, intent(in):: rk_step - integer, intent(in):: dynamics_substep + integer,intent(in):: rk_step + integer,intent(in):: dynamics_substep + procedure(halo_exchange_routine):: exchange_halo_group !inout variables: type(mpas_pool_type),intent(inout):: diag type(mpas_pool_type),intent(inout):: tend type(mpas_pool_type),intent(inout):: tend_physics - real(kind=RKIND),dimension(:,:) :: tend_ru_physics, tend_rtheta_physics, tend_rho_physics + real(kind=RKIND),intent(inout),dimension(:,:):: tend_ru_physics,tend_rtheta_physics,tend_rho_physics !local variables: - character(len=StrKIND), pointer :: config_pbl_scheme, config_convection_scheme, & - config_radt_lw_scheme, config_radt_sw_scheme + character(len=StrKIND),pointer:: pbl_scheme, & + convection_scheme, & + microp_scheme, & + radt_lw_scheme, & + radt_sw_scheme integer:: i,iCell,k,n - integer,pointer:: index_qv, index_qc, index_qr, index_qi, index_qs, index_qg - integer,pointer:: index_ni + integer,pointer:: index_qv,index_qc,index_qr,index_qi,index_qs + integer,pointer:: index_nc,index_ni,index_nifa,index_nwfa integer,pointer:: nCells,nCellsSolve,nEdges,nEdgesSolve real(kind=RKIND),dimension(:,:),pointer:: mass ! time level 2 rho_zz real(kind=RKIND),dimension(:,:),pointer:: mass_edge ! diag rho_edge 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 - real(kind=RKIND),dimension(:,:),pointer:: rniblten + rqiblten,rqsblten,rublten,rvblten + real(kind=RKIND),dimension(:,:),pointer:: rncblten,rniblten,rnifablten,rnwfablten real(kind=RKIND),dimension(:,:),pointer:: rthcuten,rqvcuten,rqccuten, & rqrcuten,rqicuten,rqscuten, & rucuten,rvcuten real(kind=RKIND),dimension(:,:),pointer:: rthratenlw,rthratensw - real(kind=RKIND),dimension(:,:),pointer:: rthdynten - real(kind=RKIND),dimension(:,:),pointer:: tend_rtheta_adv real(kind=RKIND),dimension(:,:),pointer:: tend_u_phys !nick - real(kind=RKIND),dimension(:,:),pointer :: tend_theta,tend_theta_euler,tend_diabatic,tend_u real(kind=RKIND),dimension(:,:,:),pointer:: tend_scalars - real(kind=RKIND):: coeff - real(kind=RKIND):: tem real(kind=RKIND),dimension(:,:),pointer:: rublten_Edge,rucuten_Edge - real(kind=RKIND),dimension(:,:),allocatable:: theta,tend_th - + real(kind=RKIND),dimension(:,:),allocatable:: tend_th !================================================================================================================= - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) - call mpas_pool_get_dimension(mesh, 'nEdgesSolve', nEdgesSolve) - - call mpas_pool_get_config(configs, 'config_pbl_scheme', config_pbl_scheme) - call mpas_pool_get_config(configs, 'config_convection_scheme', config_convection_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) - - call mpas_pool_get_array(state, 'theta_m', theta_m, 1) - call mpas_pool_get_array(state, 'scalars', scalars, 1) - call mpas_pool_get_array(state, 'rho_zz', mass, 2) - call mpas_pool_get_array(diag , 'rho_edge', mass_edge) - - call mpas_pool_get_array(diag , 'tend_rtheta_adv', tend_rtheta_adv) - - call mpas_pool_get_array(diag , 'tend_u_phys', tend_u_phys) !nick - - call mpas_pool_get_dimension(state, 'index_qv', index_qv) - 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) - call mpas_pool_get_dimension(state, 'index_ni', index_ni) - - call mpas_pool_get_array(tend_physics, 'rublten', rublten) - call mpas_pool_get_array(tend_physics, 'rvblten', rvblten) - call mpas_pool_get_array(tend_physics, 'rublten_Edge', rublten_Edge) - call mpas_pool_get_array(tend_physics, 'rthblten', rthblten) - 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, 'rniblten', rniblten) - - call mpas_pool_get_array(tend_physics, 'rucuten', rucuten) - call mpas_pool_get_array(tend_physics, 'rvcuten', rvcuten) - call mpas_pool_get_array(tend_physics, 'rucuten_Edge', rucuten_Edge) - call mpas_pool_get_array(tend_physics, 'rthcuten', rthcuten) - call mpas_pool_get_array(tend_physics, 'rqvcuten', rqvcuten) - call mpas_pool_get_array(tend_physics, 'rqccuten', rqccuten) - call mpas_pool_get_array(tend_physics, 'rqrcuten', rqrcuten) - call mpas_pool_get_array(tend_physics, 'rqicuten', rqicuten) - call mpas_pool_get_array(tend_physics, 'rqscuten', rqscuten) - call mpas_pool_get_array(tend_physics, 'rthdynten', rthdynten) - - call mpas_pool_get_array(tend,'rt_diabatic_tend',tend_diabatic) - - call mpas_pool_get_array(tend_physics, 'rthratenlw', rthratenlw) - call mpas_pool_get_array(tend_physics, 'rthratensw', rthratensw) - - call mpas_pool_get_array(tend,'u' , tend_u ) - call mpas_pool_get_array(tend,'theta_m' , tend_theta ) - call mpas_pool_get_array(tend,'theta_euler' ,tend_theta_euler) - call mpas_pool_get_array(tend,'scalars_tend',tend_scalars ) + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nEdges',nEdges) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nEdgesSolve',nEdgesSolve) + + 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_config(configs,'config_pbl_scheme' ,pbl_scheme ) + call mpas_pool_get_config(configs,'config_radt_lw_scheme' ,radt_lw_scheme ) + call mpas_pool_get_config(configs,'config_radt_sw_scheme' ,radt_sw_scheme ) + + call mpas_pool_get_array(state,'theta_m' ,theta_m,1) + call mpas_pool_get_array(state,'scalars' ,scalars,1) + call mpas_pool_get_array(state,'rho_zz' ,mass,2 ) + call mpas_pool_get_array(diag ,'rho_edge',mass_edge) + call mpas_pool_get_array(diag ,'tend_u_phys',tend_u_phys) + + call mpas_pool_get_dimension(state,'index_qv',index_qv) + 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_nc',index_nc) + call mpas_pool_get_dimension(state,'index_ni',index_ni) + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + call mpas_pool_get_array(tend_physics,'rublten',rublten) + call mpas_pool_get_array(tend_physics,'rvblten',rvblten) + call mpas_pool_get_array(tend_physics,'rthblten',rthblten) + 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,'rncblten',rncblten) + call mpas_pool_get_array(tend_physics,'rniblten',rniblten) + call mpas_pool_get_array(tend_physics,'rnifablten',rnifablten) + call mpas_pool_get_array(tend_physics,'rnwfablten',rnwfablten) + call mpas_pool_get_array(tend_physics,'rublten_Edge',rublten_Edge) + + call mpas_pool_get_array(tend_physics,'rucuten',rucuten) + call mpas_pool_get_array(tend_physics,'rvcuten',rvcuten) + call mpas_pool_get_array(tend_physics,'rthcuten',rthcuten) + call mpas_pool_get_array(tend_physics,'rqvcuten',rqvcuten) + call mpas_pool_get_array(tend_physics,'rqccuten',rqccuten) + call mpas_pool_get_array(tend_physics,'rqrcuten',rqrcuten) + call mpas_pool_get_array(tend_physics,'rqicuten',rqicuten) + call mpas_pool_get_array(tend_physics,'rqscuten',rqscuten) + call mpas_pool_get_array(tend_physics,'rucuten_Edge',rucuten_Edge) + + call mpas_pool_get_array(tend_physics,'rthratenlw',rthratenlw) + call mpas_pool_get_array(tend_physics,'rthratensw',rthratensw) + + call mpas_pool_get_array(tend,'scalars_tend',tend_scalars) + !initialize the tendency for the potential temperature and all scalars due to PBL, convection, !and longwave and shortwave radiation: -! allocate(theta(nVertLevels,nCellsSolve) ) allocate(tend_th(nVertLevels,nCellsSolve)) tend_th = 0._RKIND - tend_scalars(:,:,:) = 0._RKIND - - tend_ru_physics(:,:) = 0._RKIND + tend_scalars(:,:,:) = 0._RKIND + tend_ru_physics(:,:) = 0._RKIND tend_rtheta_physics(:,:) = 0._RKIND - tend_rho_physics(:,:) = 0._RKIND ! NB: rho tendency is not currently supplied by physics, but this - ! field may be later filled with IAU or other tendencies - - ! - ! In case some variables are not allocated due to their associated packages, - ! 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(rthdynten)) allocate(rthdynten(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(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)) - - call physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, & - rk_step, dynamics_substep, & - config_pbl_scheme, config_convection_scheme, config_radt_lw_scheme, config_radt_sw_scheme, & - index_qv, index_qc, index_qr, index_qi, index_qs, index_ni, & - rublten, rvblten, mass_edge, rublten_Edge, & - tend_ru_physics, & - rucuten, rvcuten, rucuten_Edge, & - tend_th, tend_scalars, mass, rthblten, rqvblten, rqcblten, rqiblten, rniblten, & - rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & - rthratenlw, rthratensw, rthdynten, & - tend_u_phys, tend_rtheta_adv, tend_diabatic, & - theta_m, scalars, & - tend_rtheta_physics, & - tend_theta_euler & - ) - - ! - ! 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(rthdynten) == 0) deallocate(rthdynten) - 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(rthcuten) == 0) deallocate(rthcuten) - if (size(rqvcuten) == 0) deallocate(rqvcuten) - if (size(rqccuten) == 0) deallocate(rqccuten) - if (size(rqicuten) == 0) deallocate(rqicuten) - -! deallocate(theta) - deallocate(tend_th) + tend_rho_physics(:,:) = 0._RKIND + + +!in case some variables are not allocated due to their associated packages. 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(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)) + + 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(rncblten)) allocate(rncblten(0,0)) + if(.not. associated(rniblten)) allocate(rniblten(0,0)) + if(.not. associated(rnifablten)) allocate(rnifablten(0,0)) + if(.not. associated(rnwfablten)) allocate(rnwfablten(0,0)) + + call physics_get_tend_work( & + block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & + pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & + index_qv,index_qc,index_qr,index_qi,index_qs, & + index_nc,index_ni,index_nifa,index_nwfa, & + mass,mass_edge,theta_m,scalars, & + rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten, & + rncblten,rniblten,rnifablten,rnwfablten, & + rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & + rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & + tend_th,tend_rtheta_physics,tend_scalars,tend_ru_physics,tend_u_phys, & + exchange_halo_group) + +!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(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) + + 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(rncblten) == 0) deallocate(rncblten) + if(size(rniblten) == 0) deallocate(rniblten) + if(size(rnifablten) == 0) deallocate(rnifablten) + if(size(rnwfablten) == 0) deallocate(rnwfablten) -! if(rk_step .eq. 3) then -! call mpas_log_write('') -! call mpas_log_write('--- enter subroutine physics_get_tend:') -! call mpas_log_write('max rthblten = $r',realArgs=(/maxval(rthblten(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthblten = $r',realArgs=(/minval(rthblten(:,1:nCellsSolve))/)) -! call mpas_log_write('max rthcuten = $r',realArgs=(/maxval(rthcuten(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthcuten = $r',realArgs=(/minval(rthcuten(:,1:nCellsSolve))/)) -! call mpas_log_write('max rthratenlw = $r',realArgs=(/maxval(rthratenlw(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthratenlw = $r',realArgs=(/minval(rthratenlw(:,1:nCellsSolve))/)) -! call mpas_log_write('max rthratensw = $r',realArgs=(/maxval(rthratensw(:,1:nCellsSolve))/)) -! call mpas_log_write('min rthratensw = $r',realArgs=(/minval(rthratensw(:,1:nCellsSolve))/)) -! call mpas_log_write('--- end subroutine physics_get_tend') -! call mpas_log_write('') -! endif + deallocate(tend_th) end subroutine physics_get_tend - !================================================================================================== - subroutine physics_get_tend_work(block, mesh, nCells, nEdges, nCellsSolve, nEdgesSolve, & - rk_step, dynamics_substep, & - config_pbl_scheme, config_convection_scheme, config_radt_lw_scheme, config_radt_sw_scheme, & - 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, & - rthcuten, rqvcuten, rqccuten, rqrcuten, rqicuten, rqscuten, & - rthratenlw, rthratensw, rthdynten, & - tend_u_phys, tend_rtheta_adv, tend_diabatic, & - theta_m, scalars, tend_theta, tend_theta_euler & - ) -!================================================================================================== - - use mpas_atm_dimensions - - implicit none - - type(block_type), intent(in) :: block - type(mpas_pool_type), intent(in) :: mesh - integer, intent(in) :: nCells, nEdges, nCellsSolve, nEdgesSolve - integer, intent(in) :: rk_step, dynamics_substep - character(len=StrKIND), intent(in) :: config_pbl_scheme - character(len=StrKIND), intent(in) :: config_convection_scheme - character(len=StrKIND), intent(in) :: config_radt_lw_scheme - character(len=StrKIND), intent(in) :: config_radt_sw_scheme - integer, intent(in) :: index_qv, index_qc, index_qr, index_qi, index_qs, index_ni - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rublten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rvblten - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(in) :: mass_edge - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rublten_Edge - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: tend_u - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rucuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rvcuten - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: rucuten_Edge - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_th - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(inout) :: tend_scalars - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: mass - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthblten - 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) :: rniblten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthcuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqvcuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqccuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqrcuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqicuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rqscuten - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthratenlw - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: rthratensw - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: rthdynten - real (kind=RKIND), dimension(nVertLevels,nEdges+1), intent(inout) :: tend_u_phys - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_rtheta_adv - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_diabatic - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: theta_m - real (kind=RKIND), dimension(num_scalars,nVertLevels,nCells+1), intent(in) :: scalars - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(inout) :: tend_theta - real (kind=RKIND), dimension(nVertLevels,nCells+1), intent(in) :: tend_theta_euler - - integer :: i, k - real (kind=RKIND) :: coeff - - !add coupled tendencies due to PBL processes: - if (config_pbl_scheme .ne. 'off') then - if (rk_step == 1 .and. dynamics_substep == 1) then - call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) - - !MGD for PV budget? should a similar line be in the cumulus section below? - tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) - end if - - do i = 1, nEdgesSolve - do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) - enddo - enddo - - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthblten(k,i)*mass(k,i) - tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvblten(k,i)*mass(k,i) - tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqcblten(k,i)*mass(k,i) - tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqiblten(k,i)*mass(k,i) - enddo - enddo - - pbl_select: select case (trim(config_pbl_scheme)) - - case("bl_mynn") +!================================================================================================================= + subroutine physics_get_tend_work( & + block,mesh,nCells,nEdges,nCellsSolve,nEdgesSolve,rk_step,dynamics_substep, & + pbl_scheme,convection_scheme,microp_scheme,radt_lw_scheme,radt_sw_scheme, & + index_qv,index_qc,index_qr,index_qi,index_qs, & + index_nc,index_ni,index_nifa,index_nwfa, & + mass,mass_edge,theta_m,scalars, & + rublten,rvblten,rthblten,rqvblten,rqcblten,rqiblten,rqsblten, & + rncblten,rniblten,rnifablten,rnwfablten, & + rucuten,rvcuten,rthcuten,rqvcuten,rqccuten,rqrcuten,rqicuten,rqscuten, & + rthratenlw,rthratensw,rublten_Edge,rucuten_Edge, & + tend_th,tend_theta,tend_scalars,tend_u,tend_u_phys, & + exchange_halo_group) +!================================================================================================================= + +!input arguments: + procedure(halo_exchange_routine):: exchange_halo_group + + type(block_type),intent(in) :: block + type(mpas_pool_type),intent(in):: mesh + + character(len=StrKIND),intent(in):: convection_scheme + character(len=StrKIND),intent(in):: microp_scheme + character(len=StrKIND),intent(in):: pbl_scheme + character(len=StrKIND),intent(in):: radt_lw_scheme + character(len=StrKIND),intent(in):: radt_sw_scheme + + integer,intent(in):: nCells,nEdges,nCellsSolve,nEdgesSolve + integer,intent(in):: rk_step,dynamics_substep + integer,intent(in):: index_qv,index_qc,index_qr,index_qi,index_qs + integer,intent(in):: index_nc,index_ni,index_nifa,index_nwfa + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: mass + real(kind=RKIND),intent(in),dimension(nVertLevels,nEdges+1):: mass_edge + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: theta_m + real(kind=RKIND),intent(in),dimension(num_scalars,nVertLevels,nCells+1):: scalars + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rublten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rvblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqvblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqcblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqiblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqsblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rncblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rniblten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rnifablten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rnwfablten + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rucuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rvcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqvcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqccuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqrcuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqicuten + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rqscuten + + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratenlw + real(kind=RKIND),intent(in),dimension(nVertLevels,nCells+1):: rthratensw + +!inout arguments: + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rublten_Edge + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: rucuten_Edge + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u + real(kind=RKIND),intent(inout),dimension(nVertLevels,nEdges+1):: tend_u_phys + + real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_th + real(kind=RKIND),intent(inout),dimension(nVertLevels,nCells+1):: tend_theta + + real(kind=RKIND),intent(inout),dimension(num_scalars,nVertLevels,nCells+1):: tend_scalars + +!local variables: + integer:: i,k + real(kind=RKIND):: coeff + +!----------------------------------------------------------------------------------------------------------------- + +!add coupled tendencies due to PBL processes: + if(pbl_scheme .ne. 'off') then + if(rk_step == 1 .and. dynamics_substep == 1) then + call exchange_halo_group(block%domain,'physics:blten') + call tend_toEdges(block,mesh,rublten,rvblten,rublten_Edge) + tend_u_phys(1:nVertLevels,1:nEdges) = rublten_Edge(1:nVertLevels,1:nEdges) + end if + + do i = 1, nEdgesSolve + do k = 1, nVertLevels + tend_u(k,i)=tend_u(k,i)+rublten_Edge(k,i)*mass_edge(k,i) + enddo + enddo + + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthblten(k,i)*mass(k,i) + tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvblten(k,i)*mass(k,i) + tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqcblten(k,i)*mass(k,i) + tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqiblten(k,i)*mass(k,i) + enddo + enddo + + pbl_select: select case(trim(pbl_scheme)) + case('bl_mynn') + 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 + + if(trim(microp_scheme) == 'mp_thompson_aerosols') then do i = 1, nCellsSolve do k = 1, nVertLevels - tend_scalars(index_ni,k,i) = tend_scalars(index_ni,k,i) + rniblten(k,i)*mass(k,i) + tend_scalars(index_nc,k,i) = tend_scalars(index_nc,k,i) + rncblten(k,i)*mass(k,i) + tend_scalars(index_nifa,k,i) = tend_scalars(index_nifa,k,i) + rnifablten(k,i)*mass(k,i) + tend_scalars(index_nwfa,k,i) = tend_scalars(index_nwfa,k,i) + rnwfablten(k,i)*mass(k,i) enddo enddo - - case default - - end select pbl_select - endif - - !add coupled tendencies due to convection: - if (config_convection_scheme .ne. 'off') then - - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthcuten(k,i)*mass(k,i) - tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvcuten(k,i)*mass(k,i) - tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqccuten(k,i)*mass(k,i) - tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqicuten(k,i)*mass(k,i) - enddo - enddo - - convection_select: select case(config_convection_scheme) - - case('cu_kain_fritsch') - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_scalars(index_qr,k,i) = tend_scalars(index_qr,k,i) + rqrcuten(k,i)*mass(k,i) - tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqscuten(k,i)*mass(k,i) - enddo - enddo - - case('cu_tiedtke','cu_ntiedtke') - if (rk_step == 1 .and. dynamics_substep == 1) then - call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) - - tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & - + rucuten_Edge(1:nVertLevels,1:nEdges) - end if - do i = 1, nEdgesSolve - do k = 1, nVertLevels - tend_u(k,i)=tend_u(k,i)+rucuten_Edge(k,i)*mass_edge(k,i) - enddo - enddo - - case default - end select convection_select - endif - - !add coupled tendencies due to longwave radiation: - if (config_radt_lw_scheme .ne. 'off') then - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthratenlw(k,i)*mass(k,i) - enddo - enddo - endif - - !add coupled tendencies due to shortwave radiation: - if (config_radt_sw_scheme .ne. 'off') then - do i = 1, nCellsSolve - do k = 1, nVertLevels - tend_th(k,i) = tend_th(k,i) + rthratensw(k,i)*mass(k,i) - enddo - enddo - endif - - !if non-hydrostatic core, convert the tendency for the potential temperature to a - !tendency for the modified potential temperature: + endif + + case default + end select pbl_select + endif + + +!add coupled tendencies due to convection: + if(convection_scheme .ne. 'off') then do i = 1, nCellsSolve do k = 1, nVertLevels - coeff = (1. + R_v/R_d * scalars(index_qv,k,i)) - tend_th(k,i) = coeff * tend_th(k,i) + R_v/R_d * theta_m(k,i) * tend_scalars(index_qv,k,i) / coeff - tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i) + tend_th(k,i) = tend_th(k,i) + rthcuten(k,i)*mass(k,i) + tend_scalars(index_qv,k,i) = tend_scalars(index_qv,k,i) + rqvcuten(k,i)*mass(k,i) + tend_scalars(index_qc,k,i) = tend_scalars(index_qc,k,i) + rqccuten(k,i)*mass(k,i) + tend_scalars(index_qi,k,i) = tend_scalars(index_qi,k,i) + rqicuten(k,i)*mass(k,i) enddo enddo + cu_select: select case(trim(convection_scheme)) + case('cu_kain_fritsch') + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_scalars(index_qr,k,i) = tend_scalars(index_qr,k,i) + rqrcuten(k,i)*mass(k,i) + tend_scalars(index_qs,k,i) = tend_scalars(index_qs,k,i) + rqscuten(k,i)*mass(k,i) + enddo + enddo + + case('cu_tiedtke','cu_ntiedtke') + if(rk_step == 1 .and. dynamics_substep == 1) then + call exchange_halo_group(block%domain,'physics:cuten') + call tend_toEdges(block,mesh,rucuten,rvcuten,rucuten_Edge) + + tend_u_phys(1:nVertLevels,1:nEdges) = tend_u_phys(1:nVertLevels,1:nEdges) & + + rucuten_Edge(1:nVertLevels,1:nEdges) + endif + do i = 1, nEdgesSolve + do k = 1, nVertLevels + tend_u(k,i)=tend_u(k,i)+rucuten_Edge(k,i)*mass_edge(k,i) + enddo + enddo + + case default + end select cu_select + endif + + +!add coupled tendencies due to longwave radiation: + if(radt_lw_scheme .ne. 'off') then + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthratenlw(k,i)*mass(k,i) + enddo + enddo + endif + + +!add coupled tendencies due to shortwave radiation: + if(radt_sw_scheme .ne. 'off') then + do i = 1, nCellsSolve + do k = 1, nVertLevels + tend_th(k,i) = tend_th(k,i) + rthratensw(k,i)*mass(k,i) + enddo + enddo + endif + + +!convert the tendency for the potential temperature to tendency for the modified potential temperature: + do i = 1, nCellsSolve + do k = 1, nVertLevels + coeff = (1. + R_v/R_d * scalars(index_qv,k,i)) + tend_th(k,i) = coeff * tend_th(k,i) + R_v/R_d * theta_m(k,i) * tend_scalars(index_qv,k,i) / coeff + tend_theta(k,i) = tend_theta(k,i) + tend_th(k,i) + enddo + enddo + + end subroutine physics_get_tend_work !================================================================================================================= @@ -448,65 +457,41 @@ subroutine tend_toEdges(block,mesh,Ux_tend,Uy_tend,U_tend) real(kind=RKIND),intent(out),dimension(:,:):: U_tend !local variables: - type (field2DReal), pointer :: tempField - type (field2DReal), target :: tempFieldTarget integer:: iCell,iEdge,k,j integer:: cell1, cell2 integer,pointer:: nCells,nCellsSolve,nEdges integer,dimension(:,:),pointer:: cellsOnEdge - real(kind=RKIND),dimension(:,:),pointer:: Ux_tend_halo,Uy_tend_halo - real(kind=RKIND), dimension(:,:), pointer :: east, north, edgeNormalVectors - + real(kind=RKIND),dimension(:,:),pointer:: east,north,edgeNormalVectors !----------------------------------------------------------------------------------------------------------------- - call mpas_pool_get_dimension(mesh, 'nCells', nCells) - call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) - call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) + call mpas_pool_get_dimension(mesh,'nCells',nCells) + call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) + call mpas_pool_get_dimension(mesh,'nEdges',nEdges) - call mpas_pool_get_array(mesh, 'east', east) - call mpas_pool_get_array(mesh, 'north', north) - call mpas_pool_get_array(mesh, 'edgeNormalVectors', edgeNormalVectors) + call mpas_pool_get_array(mesh,'east',east) + call mpas_pool_get_array(mesh,'north',north) + call mpas_pool_get_array(mesh,'edgeNormalVectors',edgeNormalVectors) - call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) - - Ux_tend_halo => Ux_tend - Uy_tend_halo => Uy_tend - - tempField => tempFieldTarget - tempField % block => block - tempField % dimSizes(1) = nVertLevels - tempField % dimSizes(2) = nCellsSolve - tempField % sendList => block % parinfo % cellsToSend - tempField % recvList => block % parinfo % cellsToRecv - tempField % copyList => block % parinfo % cellsToCopy - tempField % prev => null() - tempField % next => null() - tempField % isActive = .true. - - tempField % array => Ux_tend_halo - call mpas_dmpar_exch_halo_field(tempField) - - tempField % array => Uy_tend_halo - call mpas_dmpar_exch_halo_field(tempField) + call mpas_pool_get_array(mesh,'cellsOnEdge',cellsOnEdge) do iEdge = 1, nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) - U_tend(:,iEdge) = Ux_tend_halo(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell1) & - + edgeNormalVectors(2,iEdge) * east(2,cell1) & - + edgeNormalVectors(3,iEdge) * east(3,cell1)) & - + Uy_tend_halo(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell1) & - + edgeNormalVectors(2,iEdge) * north(2,cell1) & - + edgeNormalVectors(3,iEdge) * north(3,cell1)) & - + Ux_tend_halo(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell2) & - + edgeNormalVectors(2,iEdge) * east(2,cell2) & - + edgeNormalVectors(3,iEdge) * east(3,cell2)) & - + Uy_tend_halo(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell2) & - + edgeNormalVectors(2,iEdge) * north(2,cell2) & - + edgeNormalVectors(3,iEdge) * north(3,cell2)) + U_tend(:,iEdge) = Ux_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell1) & + + edgeNormalVectors(2,iEdge) * east(2,cell1) & + + edgeNormalVectors(3,iEdge) * east(3,cell1)) & + + Uy_tend(:,cell1) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell1) & + + edgeNormalVectors(2,iEdge) * north(2,cell1) & + + edgeNormalVectors(3,iEdge) * north(3,cell1)) & + + Ux_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * east(1,cell2) & + + edgeNormalVectors(2,iEdge) * east(2,cell2) & + + edgeNormalVectors(3,iEdge) * east(3,cell2)) & + + Uy_tend(:,cell2) * 0.5 * (edgeNormalVectors(1,iEdge) * north(1,cell2) & + + edgeNormalVectors(2,iEdge) * north(2,cell2) & + + edgeNormalVectors(3,iEdge) * north(3,cell2)) end do end subroutine tend_toEdges diff --git a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F index 684c274581..6e2057d5cb 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_update_surface.F +++ b/src/core_atmosphere/physics/mpas_atmphys_update_surface.F @@ -13,7 +13,6 @@ module mpas_atmphys_update_surface use mpas_atmphys_date_time use mpas_atmphys_constants,only: stbolt - use mpas_atmphys_landuse, only : isice,iswater use mpas_atmphys_vars implicit none @@ -41,6 +40,11 @@ module mpas_atmphys_update_surface ! Laura D. Fowler (laura@ucar.edu) / 2013-08-24. ! * modified sourcecode to use pools. ! Laura D. Fowler (laura@ucar.edu) / 2014-05-15. +! * now use isice and iswater initialized in the init file instead of initialized in mpas_atmphys_landuse.F. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-13. +! * corrected the initialization of the soil temperature tslb over ocean points for exact restartability, and +! for consistency with module_sf_noahdrv.F when itimestep = 1. +! Laura D. Fowler (laura@ucar.edu) / 2017-08-29. contains @@ -121,6 +125,7 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys integer,pointer:: nCellsSolve,nSoilLevels + integer,pointer:: isice,iswater real(kind=RKIND),dimension(:),pointer :: sfc_albbck,sst,snow,tmn,tsk,vegfra,xice,seaice real(kind=RKIND),dimension(:),pointer :: snowc,snowh @@ -144,6 +149,8 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys call mpas_pool_get_dimension(mesh,'nCellsSolve',nCellsSolve) call mpas_pool_get_dimension(mesh,'nSoilLevels',nSoilLevels) + call mpas_pool_get_array(sfc_input,'isice' ,isice ) + call mpas_pool_get_array(sfc_input,'iswater' ,iswater ) 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,'landmask' ,landmask ) @@ -263,7 +270,9 @@ subroutine physics_update_sst(dminfo,config_frac_seaice,mesh,sfc_input,diag_phys if(xland(iCell) >= 1.5_RKIND) then tsk(iCell) = sst(iCell) - tslb(1,iCell) = sst(iCell) + do iSoil = 1, nSoilLevels + tslb(iSoil,iCell) = 273.16 + enddo endif enddo !call mpas_log_write('') diff --git a/src/core_atmosphere/physics/mpas_atmphys_vars.F b/src/core_atmosphere/physics/mpas_atmphys_vars.F index 012f63befa..5485f8fef8 100644 --- a/src/core_atmosphere/physics/mpas_atmphys_vars.F +++ b/src/core_atmosphere/physics/mpas_atmphys_vars.F @@ -8,6 +8,8 @@ !================================================================================================================= module mpas_atmphys_vars use mpas_kind_types + + use NoahmpIOVarType implicit none public @@ -67,7 +69,10 @@ module mpas_atmphys_vars ! Laura D. Fowler (laura@ucar.edu) / 2016-10-21. ! * moved the declarations of arrays delta_p,wstar_p,uoce_p,and voce_p since they are now used in both modules ! module_bl_ysu.F and module_bl_mynn.F. -! Laura D. Fowler (laura@ucar.edu) / 20016-10-27. +! Laura D. Fowler (laura@ucar.edu) / 2016-10-27. +! * added the variable opt_thcnd (option to treat thermal conductivity in NoahLSM). added additional options and +! arrays to run the Noah LSM scheme from WRF version 3.9.0. +! Laura D. Fowler (laura@ucar.edu) / 2017-01-27. ! * removed the initialization local variable gwdo_scheme. gwdo_scheme is no longer needed and can be replaced ! with config_gwdo_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. @@ -95,6 +100,40 @@ module mpas_atmphys_vars ! * removed the initialization local variable microp_scheme. microp_scheme is no longer needed and can be ! replaced replaced with config_microp_scheme. ! Laura D. Fowler (laura@ucar.edu) / 2017-02-16. +! * add variables and arrays needed to the parameterization of seaice in the updated Noah land surface scheme. +! Laura D. Fowler (laura@ucar.edu) / 2017-02-19. +! * changed the option seaice_albedo_opt from 0 to 2 so that we can initialize the surface albedo over seaice +! cells using the surface background albedo (see initialization of sfc_albedo_seaice in subroutine +! landuse_init_forMPAS). +! Laura D. Fowler (laura@ucar.edu) / 2017-03-02. +! * added local variables for the mass-weighted mean velocities for rain, cloud ice, snow, and graupel from the +! 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. +! 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 +! albsi from albbck to seaice_albedo_default. +! Laura D. Fowler (laura@ucar.edu) / 2022-05-10. +! * added the local parameters flag_bep and idiff in the call to subroutine ysu to update the YSU PBL scheme to +! that of WRF version 4.4.1. +! * added local flags and variables needed to initialize and run the revised version of the MONIN-OBUKHOV surface +! layer scheme from the WRF version 4.4.1. +! Laura D. Fowler (laura@ucar.edu) / 2023-05-15. +! * 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. !================================================================================================================= @@ -167,8 +206,9 @@ module mpas_atmphys_vars qg_p !graupel mixing ratio [kg/kg] real(kind=RKIND),dimension(:,:,:),allocatable:: & - ni_p, &! - nr_p ! + nc_p, &!cloud water droplet number concentration [#/kg] + 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:: & @@ -201,26 +241,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 mixing 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). @@ -235,15 +274,11 @@ module mpas_atmphys_vars graupelncv_p, &! sr_p -!... added for the thompson and wsm6 cloud microphysics: integer:: & has_reqc, &! has_reqi, &! has_reqs - real(kind=RKIND),dimension(:,:),allocatable:: & - ntc_p, &! - muc_p ! real(kind=RKIND),dimension(:,:,:),allocatable:: & rainprod_p, &! evapprod_p, &! @@ -252,6 +287,17 @@ module mpas_atmphys_vars resnow_p, &! refl10cm_p ! +!... for Thompson cloud microphysics parameterization, including aerosol-aware option: + real(kind=RKIND),dimension(:,:),allocatable:: & + ntc_p, &! + muc_p, &! + nifa2d_p, &!surface emission of "ice-friendly" aerosols [#/kg-1/s] + nwfa2d_p !surface emission of "water-friendly" aerosols [#/kg-1/s] + + real(kind=RKIND),dimension(:,:,:),allocatable:: & + nifa_p, &!"ice-friendly" number concentration [#/kg] + nwfa_p !"water-friendly" number concentration [#/kg] + !================================================================================================================= !... variables and arrays related to parameterization of convection: !================================================================================================================= @@ -328,6 +374,14 @@ module mpas_atmphys_vars !... variables and arrays related to parameterization of pbl: !================================================================================================================= + logical,parameter:: & + flag_bep = .false. !flag to use BEP/BEP+BEM for use in the YSU PBL scheme (with urban physics). since we do + !not run urban physics, flag_bep is always set to false. + + integer,parameter:: & + idiff = 0 !BEP/BEM+BEM diffusion flag for use in the YSU PBL scheme (with urban physics). since we + !do not run urban physics, idiff is set to zero. + integer:: ysu_pblmix integer,dimension(:,:),allocatable:: & @@ -348,12 +402,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, &! @@ -361,14 +415,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, &! @@ -381,12 +437,38 @@ 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. + rncblten_p, &!tendency of cloud liquid water number concentration due to PBL processes. + rniblten_p, &!tendency of cloud ice number concentration due to PBL processes. + rnifablten_p, &!tendency of ice-friendly aerosol number concentration due to PBL processes. + rnwfablten_p !tendency of water-friendly aerosol 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: !================================================================================================================= + real(kind=RKIND),dimension(:,:),allocatable:: & + cosa_p, &!cosine of map rotation [-] + sina_p !sine of map rotation [-] + real(kind=RKIND),dimension(:,:),allocatable:: & var2d_p, &!orographic variance [m2] con_p, &!orographic convexity [m2] @@ -455,6 +537,26 @@ module mpas_atmphys_vars fh_p, &!integrated stability function for heat [-] fm_p !integrated stability function for momentum [-] +!... variables and arrays only in the revised version of monin_obukhov (module_sf_sfclayrev.F) to include the +! shallow water roughness scheme: + integer,parameter:: & + bathymetry_flag = 0!this flag is set to 1 if input bathymetry data is available (this option is not available + !in MPAS and therefore set to 0 by default. + integer,parameter:: & + shalwater_flag = 0!this flag is set to 1 to run the shallow water roughness scheme (this option is not + !available in MPAS and therefore set to 0 by default. + integer,parameter:: & + lakemodel_flag = 0!this flag is set to 1 to run the lake model physics (this option is not available in MPAS + !and therefore set to 0 by default. + + real(kind=RKIND),parameter:: & + shalwater_depth = 0!constant shallow water depth needed to run the shallow water roughness scheme. + + real(kind=RKIND),dimension(:,:),allocatable:: & + waterdepth_p, &!depth of water needed to run the shallow water roughness scheme. + lakedepth_p, &!depth of lakes needed to run the lake model physics. + lakemask_p !mask needed to detect the location of lakes to run the lake model physics. + !... arrays only in mynn surface layer scheme (module_sf_mynn.F): real(kind=RKIND),dimension(:,:),allocatable:: & ch_p, &!surface exchange coeff for heat [m/s] @@ -465,8 +567,68 @@ 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] +!================================================================================================================= +!... variables and arrays related to parameterization of seaice: +!... the options set for seaice_albedo_opt, seaice_thickness_opt, and seaicesnowdepth_opt must not be changed +! since they are the only ones currently available. +!================================================================================================================= + + integer,parameter:: & + seaice_albedo_opt = 0 !option to set albedo over sea ice. + !0 = seaice albedo is constant set in seaice_albedo_default. + !1 = seaice albedo is f(Tair,Tskin,Tsnow), following Mill (2011). + !2 = seaice albedo is read in from input variable albsi. + integer,parameter:: & + seaice_thickness_opt = 0 !option for treating seaice thickness. + !0 = seaice thickness is constant set in seaice_thickness_default. + !1 = seaice_thickness is read in from input variable icedepth. + integer,parameter:: & + seaice_snowdepth_opt = 0 !option for treating snow depth on sea ice. + !0=snow depth is bounded by seaice_snowdepth_min and seaice_snowdepth_max. + + real(kind=RKIND),parameter:: & + seaice_albedo_default = 0.65 ,&!default value of seaice albedo for seaice_albedo_opt=0. + seaice_thickness_default = 3.0, &!default value of seaice thickness for seaice_thickness_opt=0 + seaice_snowdepth_max = 1.e10,&!maximum allowed accumulation of snow (m) on sea ice. + seaice_snowdepth_min = 0.001 !minimum snow depth (m) on sea ice. + + real(kind=RKIND),dimension(:,:),allocatable:: & + albsi_p, &!surface albedo over seaice [-] + snowsi_p, &!snow depth over seaice [m] + icedepth_p !seaice thickness [m] + +!================================================================================================================= +!... variables and arrays related to the calculation of the optical properties of aerosols: to date, the only kind +! of aerosols included in MPAS are the "water-friendly" and "ice-friendly" aerosols used in the Thompson cloud +! cloud microphysics scheme. +!================================================================================================================= + + integer,parameter:: taer_aod550_opt = 2!input option for nwfa, nifa optical depth at 500 nm. + integer,parameter:: taer_angexp_opt = 3!input option for nwfa, nifa aerosol Angstrom exponent. + integer,parameter:: taer_ssa_opt = 3!input option for nwfa, nifa aerosol single-scattering albedo. + integer,parameter:: taer_asy_opt = 3!input option for nwfa, nifa aerosol asymmetry factor. + + integer:: aer_opt !=[0,3] : 0 for no aerosols, 3 for "water-" and "ice-friendly" aerosols. + integer,dimension(:,:),allocatable:: & + taer_type_p !=[1,2,3]: 1 for rural, 2 is urban and 3 is maritime in WRF. In MPAS, + !aer_type is initialized as a function of landmask (=1 over land; =2 over + !oceans. + + real(kind=RKIND),parameter:: aer_aod550_val = 0.12 + real(kind=RKIND),parameter:: aer_angexp_val = 1.3 + real(kind=RKIND),parameter:: aer_ssa_val = 0.85 + real(kind=RKIND),parameter:: aer_asy_val = 0.9 + + real(kind=RKIND),dimension(:,:),allocatable :: taod5502d_p!total aerosol optical depth at 550 nm [-] + real(kind=RKIND),dimension(:,:,:),allocatable:: taod5503d_p!aerosol optical depth at 550 nm [-] + + real(kind=RKIND),dimension(:,:,:,:),allocatable:: tauaer_p !aerosol optical depth in RRTMG SW [-] + real(kind=RKIND),dimension(:,:,:,:),allocatable:: ssaaer_p !aerosol single scatterin albedo in RRTMG SW [-] + real(kind=RKIND),dimension(:,:,:,:),allocatable:: asyaer_p !aerosol asymmetry factor in RRTMG SW [-] + !================================================================================================================= !... variables and arrays related to parameterization of short-wave radiation: !================================================================================================================= @@ -494,6 +656,11 @@ module mpas_atmphys_vars swnirdir_p, &!near-IR direct downward flux [W m-2] swnirdif_p !near-IR diffuse downward flux [W m-2] + real(kind=RKIND),dimension(:,:),allocatable:: & + swddir_p, &! + swddni_p, &! + swddif_p ! + real(kind=RKIND),dimension(:,:,:),allocatable:: & swdnflx_p, &! swdnflxc_p, &! @@ -593,9 +760,20 @@ module mpas_atmphys_vars !================================================================================================================= logical,parameter:: & - ua_phys=.false. !option to activate UA Noah changes: a different snow-cover physics in the land-surface + ua_phys = .false. !option to activate UA Noah changes: a different snow-cover physics in the land-surface !scheme. That option is not currently implemented in MPAS. + integer,parameter:: & + opt_thcnd = 1 !option to treat thermal conductivity in NoahLSM (new option implemented in WRF 3.8.0). + != 1, original (default). + != 2, McCumber and Pielke for silt loam and sandy loam. + + integer,parameter:: & + fasdas = 0 !for WRF surface data assimilation system (not used in MPAS). + + integer,parameter:: & + nurb = 1 !generic dimension for all dimensions needed to run the urban physics. + integer,public:: & sf_surface_physics !used to define the land surface scheme by a number instead of name. It !is only needed in module_ra_rrtmg_sw.F to define the spectral surface @@ -648,6 +826,28 @@ module mpas_atmphys_vars alswnirdir_p, &!direct-beam surface albedo in near-IR spectrum [-] alswnirdif_p !diffuse-beam surface albedo in near-IR spectrum [-] +!.. arrays needed to run UA Noah changes (different snow-cover physics): + real(kind=RKIND),dimension(:,:),allocatable:: & + flxsnow_p, &!energy added to sensible heat flux when ua_phys=true [W m-2] + fvbsnow_p, &!fraction of vegetation with snow beneath when ua_phys=true [-] + fbursnow_p, &!fraction of canopy buried when ua_phys=true [-] + fgsnsnow_p !fraction of ground snow cover when ua_phys=true [-] + +!.. arrays needed in the argument list in the call to the Noah LSM urban parameterization: note that these arrays +!.. are initialized to zero since we do not run an urban model: + integer,dimension(:,:),allocatable:: & + utype_urb_p !urban type [-] + + real(kind=RKIND),dimension(:,:),allocatable:: & + frc_urb_p, &!urban fraction [-] + ust_urb_p !urban u* in similarity theory [m/s] + +!================================================================================================================= +!.. variables and arrays related to the Noahmp land-surface parameterization: +!================================================================================================================= + + type(NoahmpIO_type):: mpas_noahmp + !================================================================================================================= !.. variables and arrays related to surface characteristics: !================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_noahmp/LICENSE.txt b/src/core_atmosphere/physics/physics_noahmp/LICENSE.txt new file mode 100644 index 0000000000..fad4f42322 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/LICENSE.txt @@ -0,0 +1,66 @@ +USE OF THIS SOFTWARE IS SUBJECT TO THE FOLLOWING TERMS AND CONDITIONS: + +1. License. Subject to these terms and conditions, University Corporation for Atmospheric Research (UCAR) +grants you a non-exclusive, royalty-free license to use, create derivative works, publish, distribute, +disseminate, transfer, modify, revise and copy the Noah-MP software, in both object and source code +(the "Software"). You shall not sell, license or transfer for a fee the Software, or any work that in any +manner contains the Software. + +2. Disclaimer of Warranty on Software. Use of the Software is at your sole risk. The Software is provided +"AS IS" and without warranty of any kind and UCAR EXPRESSLY DISCLAIMS ALL WARRANTIES AND/OR CONDITIONS OF +ANY KIND, EXPRESS OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, ANY WARRANTIES OR CONDITIONS OF TITLE, +NON-INFRINGEMENT OF A THIRD PARTY'S INTELLECTUAL PROPERTY, MERCHANTABILITY OR SATISFACTORY QUALITY AND +FITNESS FOR A PARTICULAR PURPOSE. THE PARTIES EXPRESSLY DISCLAIM THAT THE UNIFORM COMPUTER INFORMATION +TRANSACTIONS ACT (UCITA) APPLIES TO OR GOVERNS THIS AGREEMENT. No oral or written information or advice +given by UCAR or a UCAR authorized representative shall create a warranty or in any way increase the scope +of this warranty. Should the Software prove defective, you (and neither UCAR nor any UCAR representative) +assume the cost of all necessary correction. + +3. Limitation of Liability. UNDER NO CIRCUMSTANCES, INCLUDING NEGLIGENCE, SHALL UCAR BE LIABLE FOR ANY +DIRECT, INCIDENTAL, SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES INCLUDING LOST REVENUE, PROFIT OR DATA, +WHETHER IN AN ACTION IN CONTRACT OR TORT ARISING OUT OF OR RELATING TO THE USE OF OR INABILITY TO USE THE +SOFTWARE, EVEN IF UCAR HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. + +4. Compliance with Law. All Software and any technical data delivered under this Agreement are subject to +U.S. export control laws and may be subject to export or import regulations in other countries. You agree +to comply strictly with all applicable laws and regulations in connection with use and distribution of the +Software, including export control laws, and you acknowledge that you have responsibility to obtain any +required license to export, re-export, or import as may be required. + +5. No Endorsement/No Support. The names UCAR/NCAR, National Center for Atmospheric Research and the +University Corporation for Atmospheric Research may not be used in any advertising or publicity to endorse +or promote any products or commercial entity unless specific written permission is obtained from UCAR. The +Software is provided without any support or maintenance, and without any obligation to provide you with +modifications, improvements, enhancements, or updates of the Software. + +6. Controlling Law and Severability. This Agreement shall be governed by the laws of the United States and the +State of Colorado. If for any reason a court of competent jurisdiction finds any provision, or portion +thereof, to be unenforceable, the remainder of this Agreement shall continue in full force and effect. This +Agreement shall not be governed by the United Nations Convention on Contracts for the International Sale of +Goods, the application of which is hereby expressly excluded. + +7. Termination. Your rights under this Agreement will terminate automatically without notice from UCAR if you +fail to comply with any term(s) of this Agreement. You may terminate this Agreement at any time by destroying +the Software and any related documentation and any complete or partial copies thereof. Upon termination, all +rights granted under this Agreement shall terminate. The following provisions shall survive termination: +Sections 2, 3, 6 and 9. + +8. Complete Agreement. This Agreement constitutes the entire agreement between the parties with respect to the +use of the Software and supersedes all prior or contemporaneous understandings regarding such subject matter. +No amendment to or modification of this Agreement will be binding unless in a writing and signed by UCAR. + +9. Notices and Additional Terms. Copyright in Software is held by UCAR. You must include, with each copy of the +Software and associated documentation, a copy of this Agreement and the following notice: + +"The source of this material is the Research Applications Laboratory at the National Center for Atmospheric +Research, a program of the University Corporation for Atmospheric Research (UCAR) pursuant to a Cooperative +Agreement with the National Science Foundation; ©2007 University Corporation for Atmospheric Research. All +Rights Reserved." + +The following notice shall be displayed on any scholarly works associated with, related to or derived from +the Software: + +"The Noah-MP modeling system was developed at the National Center for Atmospheric Research (NCAR) with collaborations +from university partners. NCAR is sponsored by the United States National Science Foundation." + +BY USING OR DOWNLOADING THIS SOFTWARE, YOU AGREE TO BE BOUND BY THE TERMS AND CONDITIONS OF THIS AGREEMENT. diff --git a/src/core_atmosphere/physics/physics_noahmp/README.md b/src/core_atmosphere/physics/physics_noahmp/README.md new file mode 100644 index 0000000000..de0a3fb93d --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/README.md @@ -0,0 +1,88 @@ +![noahmp_logo_update](https://github.com/NCAR/noahmp/assets/43385564/1fb47fc2-99bd-4360-9ed0-6d5656c29626) + + +[![DOI](https://zenodo.org/badge/236657733.svg)](https://zenodo.org/badge/latestdoi/236657733) + + +# Noah-MP® Community Model Repository + +Noah-MP® is a widely-used state-of-the-art land surface model used in many research and operational weather/climate models (e.g., HRLDAS, WRF, MPAS, WRF-Hydro/NWM, NOAA/UFS, NASA/LIS, etc.). + +This is the official Noah-MP land surface model unified repository for code downloading and contribution. Noah-MP is a community open-source model developed with the contributions from the entire scientific community. For development, maintenance, and release of the community Noah-MP GitHub code, please contact: Cenlin He (cenlinhe@ucar.edu) and Fei Chen (feichen@ucar.edu). + +Noah-MP model website: https://ral.ucar.edu/solutions/products/noah-multiparameterization-land-surface-model-noah-mp-lsm + + +## New: Release of Noah-MP version 5.0 (Refactored/Modernized version) + +The latest Noah-MP model version (version 5.0) has been released in March 9, 2023, which is a modernized/refactored version by re-writing the entire model with modern Fortran code infrastructure and data structures. All future Noah-MP developments and updates will be made only to this modernized/refactored version. The version 5.0 has the same model physics as the version 4.5, but with a different code infrastructure. More details about the Noah-MP version 5.0 can be found in the model description paper (He et al., 2023b, in review) and the technical documentation (He et al. 2023a). Currently, the Noah-MP version 5.0 coupling with HRLDAS has been completed, but its coupling with other host models (e.g., WRF-Hydro, NASA/LIS, WRF, MPAS, UFS, etc.) is still on-going. + + +## Noah-MP technical documentation and model description papers + +Technical documentation freely available at http://dx.doi.org/10.5065/ew8g-yr95 + +**To cite the technical documentation**: He, C., P. Valayamkunnath, M. Barlage, F. Chen, D. Gochis, R. Cabell, T. Schneider, R. Rasmussen, G.-Y. Niu, Z.-L. Yang, D. Niyogi, and M. Ek (2023): The Community Noah-MP Land Surface Modeling System Technical Description Version 5.0, (No. NCAR/TN-575+STR). doi:10.5065/ew8g-yr95 + +**Original Noah-MP model description paper**: Niu, G. Y., Yang, Z. L., Mitchell, K. E., Chen, F., Ek, M. B., Barlage, M., ... & Xia, Y. (2011). The community Noah land surface model with multiparameterization options (Noah‐MP): 1. Model description and evaluation with local‐scale measurements. Journal of Geophysical Research: Atmospheres, 116(D12). + +**Noah-MP version 5.0 model description paper**: He, C., Valayamkunnath, P., Barlage, M., Chen, F., Gochis, D., Cabell, R., Schneider, T., Rasmussen, R., Niu, G.-Y., Yang, Z.-L., Niyogi, D., and Ek, M.: Modernizing the open-source community Noah with multi-parameterization options (Noah-MP) land surface model (version 5.0) with enhanced modularity, interoperability, and applicability, Geosci. Model Dev., 16, 5131–5151, https://doi.org/10.5194/gmd-16-5131-2023, 2023. + + +## Noah-MP GitHub structure + +**The folders**: + +1. docs/: Noah-MP variable glossary and technical documentation; + +2. drivers/: Noah-MP driver and interface code to connect to different host models (each host model will has its own subdirectory under this driver/); + +3. parameters/: Noah-MP parameter table (note that the original 3 parameter tables have been merged into one NoahmpTable.TBL starting from version 5.0); + +4. src/: Noah-MP source code modules; + +5. utility/: Noah-MP utility code. + +**The branches**: + +1. "master" branch: (currently version 5.0), most stable & latest version, updated whenever there are bug fixes or major model update/release (by merging from the "develop" branch); + +2. "develop" branch: (currently version 5.0), used for continuous NoahMP development, keep updated by including bug fixes and code updates (e.g., new physics options, processes, etc.); + +3. other version release branches: store different released code versions. + + +## Important notes + +This GitHub repository only provides the Noah-MP source code and driver/interface code. To run Noah-MP in either offline or online mode, users need to have the host model system/framework coupled with Noah-MP. + +NCAR also maintains and releases the HRLDAS (High Resolution Land Data Assimilation System) coupled with Noah-MP to allow offline Noah-MP simulations. Please see the HRLDAS GitHub repository (https://github.com/NCAR/hrldas) for details. For users who are interested in other host models that couple with Noah-MP, please refer to those host model GitHub repositories. + +For users who are interested in previous Noah-MP code versions (prior to version 5.0), please refer to the different GitHub branches in this repository. Particularly, the "release-v4.5-WRF" branch has the same model physics as the Noah-MP version 5.0, but with an old model code structures, which is consistent with the Noah-MP code released along with WRF version 4.5. + + +## Code contribution via GitHub + +Users are welcome to make code development and contributions through GitHub pull requests. The pull request will be reviewed by the Noah-MP model physics and code release team, and if everything looks good, the pull request of new code development or bug fixes will be merged into the develop branch. During each year's major version release period, the updated develop branch will be further merged into the master branch for official release of a new Noah-MP model version. + +Some suggestions for model developers to contribute to Noah-MP code through the GitHub repository (typical procedures): + +1. Step (1) Create a fork of this official Noah-MP repository to your own GitHub account; + +2. Step (2) Create a new branch based on the latest "develop" branch and make code updates/changes in the forked repository under your own account; + +3. Step (3) Finalize and test the code updates you make; + +4. Step (4) Submit a pull request for your code updates from your own forked Github repository to the "develop" branch of this official Noah-MP repository; + +5. Step (5) The Noah-MP physics and code review committee reviews and tests the model updates in the submitted pull request and discusses with the developer if there is any problem; + +6. Step (6) The Noah-MP physics and code review committee confirms the pull request and merges the updated code to the "develop" branch in this official Noah-MP repository; + +7. Step (7) The Noah-MP physics and code review committee merges the updated "develop" branch to the master branch during the annual release of new model versions. + + +## License + +The license and terms of use for this software can be found [here](https://github.com/NCAR/noahmp/blob/develop/LICENSE.txt) + diff --git a/src/core_atmosphere/physics/physics_noahmp/RELEASE_NOTES.md b/src/core_atmosphere/physics/physics_noahmp/RELEASE_NOTES.md new file mode 100644 index 0000000000..ae45c39f5a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/RELEASE_NOTES.md @@ -0,0 +1,426 @@ +# Noah-MP model release notes + +## Noah-MP version 5.0 release + +### LSM capabilities/enhancements + +- Modernization/refactoring: + + - Major re-structure/refactoring of the entire Noah-MP code with modern Fortran standards without physics changes. + +### LSM bug fixes + +- None + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- Refactored driver to work with the modernized Noah-MP version 5.0 + +### Driver bug fixes + +- None + + +## Noah-MP version 4.5 release + +### LSM capabilities/enhancements + +- Urban modeling: + + - Update the local climate zone numbers + +- Canopy heat storage: + + - bring hard-coded tunable canopy heat capacity parameter to MPTABLE + +### LSM bug fixes + +- Several bug fixes in urban, runoff, canopy, crop processes + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.4 release + +### LSM capabilities/enhancements + +- Tile drainage: + + - Add new tile drainage physics and options + +- Snowpack process enhancement: + + - Improved snow viscosity to enhance snowpack compaction + +- Canopy heat storage: + + - add canopy heat storage in vegetation temperature calculation + +- Runoff scheme: + + - Updated formulation in runoff option =1 (TOPMODEL with groundwater) + +- Soil processes: + + - Add new capabilities to allow using a different soil timestep with main Noah-MP timestep using namelist control + +- Input/output: + + - Add new capabilities to output additional detailed Noah-MP water budget terms using namelist control + +### LSM bug fixes + +- Several bug fixes in inout variables, energy, water, and canopy processes + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.3 release + +### LSM capabilities/enhancements + +- Snow-related updates: + + - Add wet-bulb temperature snow-rain partitioning scheme (OPT_SNF=5) based on Wang et al. 2019 (NWM) + - Add snow retention process at the snowpack bottom to improve streamflow modeling (NWM) + - Modify wind-canopy absorption coefficient (CWPVT) parameter values in MPTABLE to be vegetation dependent based on Goudriaan1977 + - Bring hard-coded snow emissivity and parameter (2.5*z0) in snow cover formulation to tunable MPTABLE parameters + - Update MFSNO in snow cover formulation with optimized vegetation-dependent values + - Limit the bulk leaf boundary layer resistance (RB) to a more realistic range (5~50) + +- New irrigation scheme: + + - multiple irrigation methods: sprinkler, micro, and surface flooding + +- Crop scheme update: + + - separate the original generic crop physiology parameters in the modis vegetation section into C3/C4 specific parameters in the crop section + +- New urban physics working with Noah-MP: + + - Local climate zone (LCZ), solar panel, green roof, new building drag parameterization + +### LSM bug fixes + +- None + +### External modules capabilities/enhancements + +- None + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.1 release + +### LSM capabilities/enhancements + +- Consolidate NWM changes into WRF version (#18) + - add unpopulated header required by NOAA + - add BATS parameters to data structure and output band snow albedo + - update MPTABLE for BATS albedo parameters + - add BATS albedo local variables to noahmpdrv + - transfer new BATS table values to parameters data structure in noahmpdrv + - add RSURF_EXP parameter to data structure and update MPTABLE + - change snow water equivalent limit to 5000mm + - assume LAI is stand LAI and doesn't need to be rescaled by FVEG + - conserve snow pack heat when layer melts completely + - change output messages and Fortran open/read unit numbers to WCOSS standard + - include a few missed changes from WRF + +### LSM bug fixes + +- Define and declare a few variables in physics routines + +- Noah-MP bulk urban roughness length set to table values + +### External modules capabilities/enhancements + +- Air conditioning fraction for BEM model + +- Improve urban memory by allowing different dimensions for urban variables + +### Driver capabilities/enhancements + +- None + +### Driver bug fixes + +- None + + +## Noah-MP version 4.0.1 release + +### LSM capabilities/enhancements + +- None + +### LSM bug fixes + +- Noah-MP frozen soil initialization- An incorrect sign change was introduced in v4.0, impacting soil moisture and soil temperature initialization. + +- Array out of bounds Noah-MP - Fix possible/likely array out of bounds by assuming homogeneous soil with depth.Only applies to opt_run=2. + +- Noah-MP snow liquid water movement - prevent excessive gravitational water movement. Fixes unrealistic snow density values during melt season. + +- Noah-MP divide by zero - Bug fix in v4.0 introduced a possible divide by zero when LAI is zero. + +- Noah-MP leaf aerodynamic resistance - limit leaf aerodynamic resistance to prevent very large canopy exchange coefficients with high wind speed. + +### Driver capabilities/enhancements + +- Add new single point driver based on Bondville data + +### Driver bug fixes + +- Missing quotation mark in spatial_filename check print statement + + +## Noah-MP version 4.0 release + +### LSM capabilities/enhancements + +- Add pedotransfer function option for soil propertis + - add optional read for soil composition and multi-layer soil texture from setup/input file + - activated with opt_soil and opt_pedo + - update MPTABLE.TBL with pedotransfer function coefficients + +- Add Gecros crop model + - activated with opt_crop=2 (Liu et al. crop now opt_crop=1) + - some modifications for crop initialization + +- Groundwater module (opt_run=5) updates + - move init to driver for parallel capability + - remove rivermask/nonriver from input + +- EPA modifications to output total stomatal resistance + +### LSM bug fixes + +- None + +### Driver capabilities/enhancements + +- Change some predefined defaults in user_build_options.compiler files based on some Cheyenne tests + +- Add ISLAKE to the preprocessing and driver to accommodate WRF files that define a distinct lake category + +### Driver bug fixes + +- Change PGSXY and CROPCAT to be initialized undefined_int + + +## Noah-MP version 3.9 release + +### LSM capabilities/enhancements + +- Crop modifications in v3.9 to read in crop datasets and initialize properly + +- Modifications in v3.9 to read in groundwater datasets + +- Noah-MP can now run with single-layer and multi-layer urban models + +### LSM bug fixes + +- Several fixes in Section 1 of SOILPARM.TBL + +- Fix strange Noah-MP behavior in soil water in certain conditions + +- Fix uninitialized variable in Noah-MP surface exchange option + +### Driver capabilities/enhancements + +- Add capability to include snow in forcing files + - Need to set FORCING_NAME_SN and PCP_PARTITION_OPTION = 4 + - Snow is assumed to be <= incoming precipitation + +- Add capability to define name of forcing variables in namelist.hrldas + +- Add spinup option to namelist + - controlled by spinup_loops in namelist.hrldas + - will run kday/khour spinup_loops times before starting the simulation + +- Add capability to exclude the first output file since this file contains only initial states + - and no computed fluxes + - activated by namelist.hrldas option: SKIP_FIRST_OUTPUT = .true. + +- Added README.namelist to describe all the namelist.hrldas options + +### Driver bug fixes + +- None + + +## Noah-MP version 3.8.1 release + +### LSM capabilities/enhancements + +- None + +### LSM bug fixes + +- Change C3C4 in MPTABLE to integer + +- Set some limits on stability function for OPT_SFC = 2 + +- Change limit for minimum wood pool in dynamic vegetation + +- Fix bug in QSFC calculation + +- Prevent divide by zero when soil moisture is zero + +- Fix a few bugs in the crop code; make DVEG = 10 activate crop model + +### Driver capabilities/enhancements + +- Added configure script for generating user_build_options file + +### Driver bug fixes + +- None + + +## Noah-MP version 3.8 release + +### LSM capabilities/enhancements + +- Added 3 new dveg option for reading LAI from forcing and 1 new dveg option for reading FVEG; + + - Also added initial commit of crop model; currently runs crop everywhere + - dveg = 6 -> dynamic vegetation on (use FVEG = SHDFAC from input) + - dveg = 7 -> dynamic vegetation off (use input LAI; use FVEG = SHDFAC from input) + - dveg = 8 -> dynamic vegetation off (use input LAI; calculate FVEG) + - dveg = 9 -> dynamic vegetation off (use input LAI; use maximum vegetation fraction) + - dveg = 10 -> crop model on (use maximum vegetation fraction) + +- Added glacier options: + + - opt_gla = 1 -> original Noah-MP version + - opt_gla = 2 -> no ice phase change or sublimation (like Noah glacier) + +- Added surface resistance as an option (now four options) + + - opt_sfc = 1 -> Sakaguchi and Zeng, 2009 (has been Noah-MP default) + - opt_sfc = 2 -> Sellers (1992) + - opt_sfc = 3 -> adjusted Sellers to decrease RSURF for wet soil + - opt_sfc = 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set as RSURF_SNOW in MPTABLE) + +- Made the specification of urban types more general + + - (LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL), + - now set in the MPTABLE dependent on classification scheme (i.e., not limited to 31,32,33); + - this is for future coupling with urban models. + +### LSM bug fixes + +- Fixed two bugs with OPT_STC=3 + +- Fixed bug in new surface resistance option causing divide by 0 + +- Write a message if incoming snow water and snow depth are inconsistent; + Reduce SWE to 2000mm if input is >2000mm, Noah-MP limits SWE internally to 2000mm + +- Recalculate ESTG in glacier code when snow is melting, will decrease sublimation, but likely increase melting + +### Driver capabilities/enhancements + +- Added instructions and scripts for extraction of single point forcing and setup files from + 2D datasets (e.g., NLDAS) + +- Structure for spatially-varying soil properties added to DRV and LSM; + Use of the 2D/3D fields in the driver and DRV commented to be consistent with WRF + +### Driver bug fixes + +- Zero forcing where not land to prevent overflow with ifort + + +## Noah-MP version 3.7.1 release + +### LSM capabilities/enhancements + +- Added depth dimension to soil parameters. + +### LSM bug fixes + +- Reorganized parameters to fix problems with OpenMP in WRF simulations. + +### Driver capabilities/enhancements + +- none + +### Driver bug fixes + +- Initialized some accumulated fields at 0 (instead of undefined). + + +## Noah-MP version 3.7 release + +### New capabilities: + +- A parallel capability has been added by Wei Yu (weiyu@ncar.edu) to support mpi only. + + - To compile with parallel version, edit the file 'user_build_options', + uncommment the compiler section with MPI (available for pgf90 and ifort compilers) + - To compile with sequential version, edit the file 'user_build_options', uncommment the compiler section without MPI + +- System setup and execution now requires only a WRF/WPS geo_em file, Dependence on the wrfinput file has been removed. + +- As part of #2, initialization no longer occurs in the first forcing file, + + - but in the file listed in the namelist as: HRLDAS_SETUP_FILE = " + - The initialization fields are: SNOW,CANWAT,TSK,TSLB,SMOIS + - This file also contains the static grid/domain information: XLAT,XLONG,TMN,HGT,SEAICE,MAPFAC_MX,MAPFAC_MY,SHDMAX,SHDMIN,XLAND,IVGTYP,ISLTYP,DZS,ZS + - This file can also contains some optional fields: LAI + - NOTE: a WRF input file can be used as a HRLDAS_SETUP_FILE + +- The timing structure has changed: + + - The initial conditions are the states at START time. + - First forcing file used is START time + FORCING_TIMESTEP + - First integration is START time + NOAH_TIMESTEP + +- First output file is now START time + OUTPUT_TIMESTEP + +- RESTART file states are consistent with OUTPUT file states with the same time stamp + +- Instructions for using GLDAS and NLDAS as forcing has been provided in addition to the NARR instructions (see /docs) + - Also, a NCL script has been included for preparing single- or multi-point forcing + +- Initial LAI (if present in the HRLDAS_SETUP_FILE) will be used to initialize the leaf and stem carbon pools + +- Removed dependence on external GRIB tables for forcing creation; now in namelist only + + + +Updated: March 10, 2023 diff --git a/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_refactored_variable_name_glossary_Feb2023.xlsx b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_refactored_variable_name_glossary_Feb2023.xlsx new file mode 100644 index 0000000000..8008b630b6 Binary files /dev/null and b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_refactored_variable_name_glossary_Feb2023.xlsx differ diff --git a/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_v5_technote.pdf b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_v5_technote.pdf new file mode 100644 index 0000000000..cc0e9eaf43 Binary files /dev/null and b/src/core_atmosphere/physics/physics_noahmp/docs/NoahMP_v5_technote.pdf differ diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarInTransferMod.F90 new file mode 100644 index 0000000000..82d041957e --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarInTransferMod.F90 @@ -0,0 +1,148 @@ +module BiochemVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Biochemistry variables to 1-D column variable +!!! 1-D variables should be first defined in /src/BiochemVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine BiochemVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + VegType => noahmp%config%domain%VegType ,& + CropType => noahmp%config%domain%CropType ,& + OptCropModel => noahmp%config%nmlist%OptCropModel & + ) +! ------------------------------------------------------------------------- + + ! biochem state variables + noahmp%biochem%state%PlantGrowStage = NoahmpIO%PGSXY (I) + noahmp%biochem%state%LeafMass = NoahmpIO%LFMASSXY(I) + noahmp%biochem%state%RootMass = NoahmpIO%RTMASSXY(I) + noahmp%biochem%state%StemMass = NoahmpIO%STMASSXY(I) + noahmp%biochem%state%WoodMass = NoahmpIO%WOODXY (I) + noahmp%biochem%state%CarbonMassDeepSoil = NoahmpIO%STBLCPXY(I) + noahmp%biochem%state%CarbonMassShallowSoil = NoahmpIO%FASTCPXY(I) + noahmp%biochem%state%GrainMass = NoahmpIO%GRAINXY (I) + noahmp%biochem%state%GrowDegreeDay = NoahmpIO%GDDXY (I) + noahmp%biochem%state%NitrogenConcFoliage = 1.0 ! for now, set to nitrogen saturation + + ! biochem parameter variables + noahmp%biochem%param%NitrogenConcFoliageMax = NoahmpIO%FOLNMX_TABLE (VegType) + noahmp%biochem%param%QuantumEfficiency25C = NoahmpIO%QE25_TABLE (VegType) + noahmp%biochem%param%CarboxylRateMax25C = NoahmpIO%VCMX25_TABLE (VegType) + noahmp%biochem%param%CarboxylRateMaxQ10 = NoahmpIO%AVCMX_TABLE (VegType) + noahmp%biochem%param%PhotosynPathC3 = NoahmpIO%C3PSN_TABLE (VegType) + noahmp%biochem%param%SlopeConductToPhotosyn = NoahmpIO%MP_TABLE (VegType) + noahmp%biochem%param%RespMaintQ10 = NoahmpIO%ARM_TABLE (VegType) + noahmp%biochem%param%RespMaintLeaf25C = NoahmpIO%RMF25_TABLE (VegType) + noahmp%biochem%param%RespMaintStem25C = NoahmpIO%RMS25_TABLE (VegType) + noahmp%biochem%param%RespMaintRoot25C = NoahmpIO%RMR25_TABLE (VegType) + noahmp%biochem%param%WoodToRootRatio = NoahmpIO%WRRAT_TABLE (VegType) + noahmp%biochem%param%WoodPoolIndex = NoahmpIO%WDPOOL_TABLE (VegType) + noahmp%biochem%param%TurnoverCoeffLeafVeg = NoahmpIO%LTOVRC_TABLE (VegType) + noahmp%biochem%param%TemperaureLeafFreeze = NoahmpIO%TDLEF_TABLE (VegType) + noahmp%biochem%param%LeafDeathWaterCoeffVeg = NoahmpIO%DILEFW_TABLE (VegType) + noahmp%biochem%param%LeafDeathTempCoeffVeg = NoahmpIO%DILEFC_TABLE (VegType) + noahmp%biochem%param%GrowthRespFrac = NoahmpIO%FRAGR_TABLE (VegType) + noahmp%biochem%param%MicroRespCoeff = NoahmpIO%MRP_TABLE (VegType) + noahmp%biochem%param%TemperatureMinPhotosyn = NoahmpIO%TMIN_TABLE (VegType) + noahmp%biochem%param%LeafAreaPerMass1side = NoahmpIO%SLA_TABLE (VegType) + noahmp%biochem%param%StemAreaIndexMin = NoahmpIO%XSAMIN_TABLE (VegType) + noahmp%biochem%param%WoodAllocFac = NoahmpIO%BF_TABLE (VegType) + noahmp%biochem%param%WaterStressCoeff = NoahmpIO%WSTRC_TABLE (VegType) + noahmp%biochem%param%LeafAreaIndexMin = NoahmpIO%LAIMIN_TABLE (VegType) + noahmp%biochem%param%TurnoverCoeffRootVeg = NoahmpIO%RTOVRC_TABLE (VegType) + noahmp%biochem%param%WoodRespCoeff = NoahmpIO%RSWOODC_TABLE(VegType) + ! crop model specific parameters + if ( (OptCropModel > 0) .and. (CropType > 0) ) then + noahmp%biochem%param%DatePlanting = NoahmpIO%PLTDAY_TABLE (CropType) + noahmp%biochem%param%DateHarvest = NoahmpIO%HSDAY_TABLE (CropType) + noahmp%biochem%param%NitrogenConcFoliageMax = NoahmpIO%FOLNMXI_TABLE (CropType) + noahmp%biochem%param%QuantumEfficiency25C = NoahmpIO%QE25I_TABLE (CropType) + noahmp%biochem%param%CarboxylRateMax25C = NoahmpIO%VCMX25I_TABLE (CropType) + noahmp%biochem%param%CarboxylRateMaxQ10 = NoahmpIO%AVCMXI_TABLE (CropType) + noahmp%biochem%param%PhotosynPathC3 = NoahmpIO%C3PSNI_TABLE (CropType) + noahmp%biochem%param%SlopeConductToPhotosyn = NoahmpIO%MPI_TABLE (CropType) + noahmp%biochem%param%RespMaintQ10 = NoahmpIO%Q10MR_TABLE (CropType) + noahmp%biochem%param%RespMaintLeaf25C = NoahmpIO%LFMR25_TABLE (CropType) + noahmp%biochem%param%RespMaintStem25C = NoahmpIO%STMR25_TABLE (CropType) + noahmp%biochem%param%RespMaintRoot25C = NoahmpIO%RTMR25_TABLE (CropType) + noahmp%biochem%param%GrowthRespFrac = NoahmpIO%FRA_GR_TABLE (CropType) + noahmp%biochem%param%TemperaureLeafFreeze = NoahmpIO%LEFREEZ_TABLE (CropType) + noahmp%biochem%param%LeafAreaPerBiomass = NoahmpIO%BIO2LAI_TABLE (CropType) + noahmp%biochem%param%TempBaseGrowDegDay = NoahmpIO%GDDTBASE_TABLE (CropType) + noahmp%biochem%param%TempMaxGrowDegDay = NoahmpIO%GDDTCUT_TABLE (CropType) + noahmp%biochem%param%GrowDegDayEmerg = NoahmpIO%GDDS1_TABLE (CropType) + noahmp%biochem%param%GrowDegDayInitVeg = NoahmpIO%GDDS2_TABLE (CropType) + noahmp%biochem%param%GrowDegDayPostVeg = NoahmpIO%GDDS3_TABLE (CropType) + noahmp%biochem%param%GrowDegDayInitReprod = NoahmpIO%GDDS4_TABLE (CropType) + noahmp%biochem%param%GrowDegDayMature = NoahmpIO%GDDS5_TABLE (CropType) + noahmp%biochem%param%PhotosynRadFrac = NoahmpIO%I2PAR_TABLE (CropType) + noahmp%biochem%param%TempMinCarbonAssim = NoahmpIO%TASSIM0_TABLE (CropType) + noahmp%biochem%param%TempMaxCarbonAssim = NoahmpIO%TASSIM1_TABLE (CropType) + noahmp%biochem%param%TempMaxCarbonAssimMax = NoahmpIO%TASSIM2_TABLE (CropType) + noahmp%biochem%param%CarbonAssimRefMax = NoahmpIO%AREF_TABLE (CropType) + noahmp%biochem%param%LightExtCoeff = NoahmpIO%K_TABLE (CropType) + noahmp%biochem%param%LightUseEfficiency = NoahmpIO%EPSI_TABLE (CropType) + noahmp%biochem%param%CarbonAssimReducFac = NoahmpIO%PSNRF_TABLE (CropType) + noahmp%biochem%param%RespMaintGrain25C = NoahmpIO%GRAINMR25_TABLE(CropType) + noahmp%biochem%param%LeafDeathTempCoeffCrop = NoahmpIO%DILE_FC_TABLE (CropType,:) + noahmp%biochem%param%LeafDeathWaterCoeffCrop = NoahmpIO%DILE_FW_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrLeafToGrain = NoahmpIO%LFCT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrStemToGrain = NoahmpIO%STCT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrRootToGrain = NoahmpIO%RTCT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToLeaf = NoahmpIO%LFPT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToStem = NoahmpIO%STPT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToRoot = NoahmpIO%RTPT_TABLE (CropType,:) + noahmp%biochem%param%CarbohydrFracToGrain = NoahmpIO%GRAINPT_TABLE (CropType,:) + noahmp%biochem%param%TurnoverCoeffLeafCrop = NoahmpIO%LF_OVRC_TABLE (CropType,:) + noahmp%biochem%param%TurnoverCoeffStemCrop = NoahmpIO%ST_OVRC_TABLE (CropType,:) + noahmp%biochem%param%TurnoverCoeffRootCrop = NoahmpIO%RT_OVRC_TABLE (CropType,:) + + if ( OptCropModel == 1 ) then + noahmp%biochem%param%DatePlanting = NoahmpIO%PLANTING(I) + noahmp%biochem%param%DateHarvest = NoahmpIO%HARVEST(I) + noahmp%biochem%param%GrowDegDayEmerg = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayEmerg + noahmp%biochem%param%GrowDegDayInitVeg = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayInitVeg + noahmp%biochem%param%GrowDegDayPostVeg = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayPostVeg + noahmp%biochem%param%GrowDegDayInitReprod = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayInitReprod + noahmp%biochem%param%GrowDegDayMature = NoahmpIO%SEASON_GDD(I) / 1770.0 * & + noahmp%biochem%param%GrowDegDayMature + endif + endif ! activate crop parameters + + if ( noahmp%config%nmlist%OptIrrigation == 2 ) then + noahmp%biochem%param%DatePlanting = NoahmpIO%PLANTING(I) + noahmp%biochem%param%DateHarvest = NoahmpIO%HARVEST (I) + endif + + end associate + + end subroutine BiochemVarInTransfer + +end module BiochemVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarOutTransferMod.F90 new file mode 100644 index 0000000000..b8e81b65f6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/BiochemVarOutTransferMod.F90 @@ -0,0 +1,54 @@ +module BiochemVarOutTransferMod + +!!! Transfer column (1-D) biochemistry variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine BiochemVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! --------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI & + ) +! --------------------------------------------------------------------- + + ! biochem state variables + NoahmpIO%LFMASSXY(I) = noahmp%biochem%state%LeafMass + NoahmpIO%RTMASSXY(I) = noahmp%biochem%state%RootMass + NoahmpIO%STMASSXY(I) = noahmp%biochem%state%StemMass + NoahmpIO%WOODXY (I) = noahmp%biochem%state%WoodMass + NoahmpIO%STBLCPXY(I) = noahmp%biochem%state%CarbonMassDeepSoil + NoahmpIO%FASTCPXY(I) = noahmp%biochem%state%CarbonMassShallowSoil + NoahmpIO%GDDXY (I) = noahmp%biochem%state%GrowDegreeDay + NoahmpIO%PGSXY (I) = noahmp%biochem%state%PlantGrowStage + NoahmpIO%GRAINXY (I) = noahmp%biochem%state%GrainMass + + ! biochem flux variables + NoahmpIO%NEEXY (I) = noahmp%biochem%flux%NetEcoExchange + NoahmpIO%GPPXY (I) = noahmp%biochem%flux%GrossPriProduction + NoahmpIO%NPPXY (I) = noahmp%biochem%flux%NetPriProductionTot + NoahmpIO%PSNXY (I) = noahmp%biochem%flux%PhotosynTotal + + end associate + + end subroutine BiochemVarOutTransfer + +end module BiochemVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarInTransferMod.F90 new file mode 100644 index 0000000000..2de35ed9c2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarInTransferMod.F90 @@ -0,0 +1,170 @@ +module ConfigVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Configuration variables to 1-D column variable +!!! 1-D variables should be first defined in /src/ConfigVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input/restart data or table values + + subroutine ConfigVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type) , intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + +! --------------------------------------------------------------------- + associate( & + I => NoahmpIO%I ,& + NumSnowLayerMax => NoahmpIO%NSNOW ,& + NumSoilLayer => NoahmpIO%NSOIL & + ) +! --------------------------------------------------------------------- + + ! config namelist variable + noahmp%config%nmlist%OptDynamicVeg = NoahmpIO%IOPT_DVEG + noahmp%config%nmlist%OptRainSnowPartition = NoahmpIO%IOPT_SNF + noahmp%config%nmlist%OptSoilWaterTranspiration = NoahmpIO%IOPT_BTR + noahmp%config%nmlist%OptGroundResistanceEvap = NoahmpIO%IOPT_RSF + noahmp%config%nmlist%OptSurfaceDrag = NoahmpIO%IOPT_SFC + noahmp%config%nmlist%OptStomataResistance = NoahmpIO%IOPT_CRS + noahmp%config%nmlist%OptSnowAlbedo = NoahmpIO%IOPT_ALB + noahmp%config%nmlist%OptCanopyRadiationTransfer = NoahmpIO%IOPT_RAD + noahmp%config%nmlist%OptSnowSoilTempTime = NoahmpIO%IOPT_STC + noahmp%config%nmlist%OptSnowThermConduct = NoahmpIO%IOPT_TKSNO + noahmp%config%nmlist%OptSoilTemperatureBottom = NoahmpIO%IOPT_TBOT + noahmp%config%nmlist%OptSoilSupercoolWater = NoahmpIO%IOPT_FRZ + noahmp%config%nmlist%OptSoilPermeabilityFrozen = NoahmpIO%IOPT_INF + noahmp%config%nmlist%OptDynVicInfiltration = NoahmpIO%IOPT_INFDV + noahmp%config%nmlist%OptTileDrainage = NoahmpIO%IOPT_TDRN + noahmp%config%nmlist%OptIrrigation = NoahmpIO%IOPT_IRR + noahmp%config%nmlist%OptIrrigationMethod = NoahmpIO%IOPT_IRRM + noahmp%config%nmlist%OptCropModel = NoahmpIO%IOPT_CROP + noahmp%config%nmlist%OptSoilProperty = NoahmpIO%IOPT_SOIL + noahmp%config%nmlist%OptPedotransfer = NoahmpIO%IOPT_PEDO + noahmp%config%nmlist%OptRunoffSurface = NoahmpIO%IOPT_RUNSRF + noahmp%config%nmlist%OptRunoffSubsurface = NoahmpIO%IOPT_RUNSUB + noahmp%config%nmlist%OptGlacierTreatment = NoahmpIO%IOPT_GLA + + ! config domain variable + noahmp%config%domain%SurfaceType = 1 + noahmp%config%domain%NumSwRadBand = 2 + noahmp%config%domain%SoilColor = 4 + noahmp%config%domain%NumCropGrowStage = 8 + noahmp%config%domain%FlagSoilProcess = NoahmpIO%calculate_soil + noahmp%config%domain%NumSoilTimeStep = NoahmpIO%soil_update_steps + noahmp%config%domain%NumSnowLayerMax = NoahmpIO%NSNOW + noahmp%config%domain%NumSnowLayerNeg = NoahmpIO%ISNOWXY(I) + noahmp%config%domain%NumSoilLayer = NoahmpIO%NSOIL + noahmp%config%domain%GridIndexI = NoahmpIO%I + noahmp%config%domain%GridIndexJ = NoahmpIO%J + noahmp%config%domain%MainTimeStep = NoahmpIO%DTBL + noahmp%config%domain%SoilTimeStep = NoahmpIO%DTBL * NoahmpIO%soil_update_steps + noahmp%config%domain%GridSize = NoahmpIO%DX + noahmp%config%domain%LandUseDataName = NoahmpIO%LLANDUSE + noahmp%config%domain%VegType = NoahmpIO%IVGTYP(I) + noahmp%config%domain%CropType = NoahmpIO%CROPCAT(I) + noahmp%config%domain%IndicatorIceSfc = NoahmpIO%ICE + noahmp%config%domain%DayJulianInYear = NoahmpIO%JULIAN + noahmp%config%domain%NumDayInYear = NoahmpIO%YEARLEN + noahmp%config%domain%Latitude = NoahmpIO%XLAT(I) + noahmp%config%domain%RefHeightAboveSfc = NoahmpIO%DZ8W(I,1)*0.5 + noahmp%config%domain%ThicknessAtmosBotLayer = NoahmpIO%DZ8W(I,1) + noahmp%config%domain%CosSolarZenithAngle = NoahmpIO%COSZEN(I) + noahmp%config%domain%IndexWaterPoint = NoahmpIO%ISWATER_TABLE + noahmp%config%domain%IndexBarrenPoint = NoahmpIO%ISBARREN_TABLE + noahmp%config%domain%IndexIcePoint = NoahmpIO%ISICE_TABLE + noahmp%config%domain%IndexCropPoint = NoahmpIO%ISCROP_TABLE + noahmp%config%domain%IndexEBLForest = NoahmpIO%EBLFOREST_TABLE + noahmp%config%domain%RunoffSlopeType = NoahmpIO%SLOPETYP + noahmp%config%domain%DepthSoilTempBottom = NoahmpIO%ZBOT_TABLE + + ! the following initialization cannot be done in ConfigVarInitMod + ! because the NumSoilLayer and NumSnowLayerMax are initialized with input values in this module + if ( .not. allocated(noahmp%config%domain%DepthSoilLayer) ) & + allocate( noahmp%config%domain%DepthSoilLayer(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%ThicknessSoilLayer) ) & + allocate( noahmp%config%domain%ThicknessSoilLayer(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%SoilType) ) & + allocate( noahmp%config%domain%SoilType(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%ThicknessSnowSoilLayer) ) & + allocate( noahmp%config%domain%ThicknessSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%config%domain%DepthSnowSoilLayer) ) & + allocate( noahmp%config%domain%DepthSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) ) + + noahmp%config%domain%SoilType (:) = undefined_int + noahmp%config%domain%DepthSoilLayer (:) = undefined_real + noahmp%config%domain%ThicknessSoilLayer (:) = undefined_real + noahmp%config%domain%ThicknessSnowSoilLayer(:) = undefined_real + noahmp%config%domain%DepthSnowSoilLayer (:) = undefined_real + + if ( noahmp%config%nmlist%OptSoilProperty == 1 ) then + noahmp%config%domain%SoilType(1:NumSoilLayer) = NoahmpIO%ISLTYP(I) ! soil type same in all layers + elseif ( noahmp%config%nmlist%OptSoilProperty == 2 ) then + noahmp%config%domain%SoilType(1) = nint(NoahmpIO%SOILCL1(I)) ! soil type in layer1 + noahmp%config%domain%SoilType(2) = nint(NoahmpIO%SOILCL2(I)) ! soil type in layer2 + noahmp%config%domain%SoilType(3) = nint(NoahmpIO%SOILCL3(I)) ! soil type in layer3 + noahmp%config%domain%SoilType(4) = nint(NoahmpIO%SOILCL4(I)) ! soil type in layer4 + elseif ( noahmp%config%nmlist%OptSoilProperty == 3 ) then + noahmp%config%domain%SoilType(1:NumSoilLayer) = NoahmpIO%ISLTYP(I) ! to initialize with default + endif + + noahmp%config%domain%DepthSoilLayer(1:NumSoilLayer) = NoahmpIO%ZSOIL(1:NumSoilLayer) + noahmp%config%domain%DepthSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) = & + NoahmpIO%ZSNSOXY(I,-NumSnowLayerMax+1:NumSoilLayer) + + ! treatment for urban point + if ( (NoahmpIO%IVGTYP(I) == NoahmpIO%ISURBAN_TABLE) .or. (NoahmpIO%IVGTYP(I) > NoahmpIO%URBTYPE_beg) ) then + noahmp%config%domain%FlagUrban = .true. + if(NoahmpIO%SF_URBAN_PHYSICS == 0 ) then + noahmp%config%domain%VegType = NoahmpIO%ISURBAN_TABLE + else + noahmp%config%domain%VegType = NoahmpIO%NATURAL_TABLE ! set urban vegetation type based on table natural + NoahmpIO%GVFMAX(I) = 0.96 * 100.0 ! unit: % + endif + endif + + ! treatment for crop point + noahmp%config%domain%CropType = 0 + if ( (NoahmpIO%IOPT_CROP > 0) .and. (NoahmpIO%IVGTYP(I) == NoahmpIO%ISCROP_TABLE) ) & + noahmp%config%domain%CropType = NoahmpIO%DEFAULT_CROP_TABLE + + if ( (NoahmpIO%IOPT_CROP > 0) .and. (NoahmpIO%CROPCAT(I) > 0) ) then + noahmp%config%domain%CropType = NoahmpIO%CROPCAT(I) + noahmp%config%domain%VegType = NoahmpIO%ISCROP_TABLE + NoahmpIO%VEGFRA(I) = 0.95 * 100.0 ! unit: % + NoahmpIO%GVFMAX(I) = 0.95 * 100.0 ! unit: % + endif + + ! correct inconsistent soil type + if ( any(noahmp%config%domain%SoilType == 14) .and. (NoahmpIO%XICE(I) == 0.0) ) then + write(*,*) "SOIL TYPE FOUND TO BE WATER AT A LAND-POINT" + write(*,*) "RESET SOIL type to SANDY CLAY LOAM at grid = ", I + noahmp%config%domain%SoilType = 7 + endif + + ! set warning message for inconsistent surface and subsurface runoff option + ! for now, only the same options for surface and subsurface runoff have been tested + if ( noahmp%config%nmlist%OptRunoffSurface /= noahmp%config%nmlist%OptRunoffSubsurface ) then + write(*,*) "Warning: Surface and subsurface runoff options are inconsistent! They may be incompatible!" + write(*,*) "Warning: Currently only the same options for surface and subsurface runoff are tested." + endif + + end associate + + end subroutine ConfigVarInTransfer + +end module ConfigVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarOutTransferMod.F90 new file mode 100644 index 0000000000..d261f45b90 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ConfigVarOutTransferMod.F90 @@ -0,0 +1,45 @@ +module ConfigVarOutTransferMod + +!!! To transfer 1D Noah-MP column Config variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output===== + + subroutine ConfigVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type) , intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + +! ---------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer & + ) +! ---------------------------------------------------------------------- + + ! config domain variables + NoahmpIO%ISNOWXY(I) = noahmp%config%domain%NumSnowLayerNeg + NoahmpIO%ZSNSOXY(I,-NumSnowLayerMax+1:NumSoilLayer) = & + noahmp%config%domain%DepthSnowSoilLayer(-NumSnowLayerMax+1:NumSoilLayer) + NoahmpIO%FORCZLSM(I) = noahmp%config%domain%RefHeightAboveSfc + + end associate + + end subroutine ConfigVarOutTransfer + +end module ConfigVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarInTransferMod.F90 new file mode 100644 index 0000000000..f0a96a5795 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarInTransferMod.F90 @@ -0,0 +1,154 @@ +module EnergyVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Energy variables to 1-D column variable +!!! 1-D variables should be first defined in /src/EnergyVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine EnergyVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + + ! local loop index + integer :: SoilLayerIndex + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + VegType => noahmp%config%domain%VegType ,& + SoilType => noahmp%config%domain%SoilType ,& + CropType => noahmp%config%domain%CropType ,& + SoilColor => noahmp%config%domain%SoilColor ,& + FlagUrban => noahmp%config%domain%FlagUrban ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + NumSwRadBand => noahmp%config%domain%NumSwRadBand & + ) +! ------------------------------------------------------------------------- + + ! energy state variables + noahmp%energy%state%LeafAreaIndex = NoahmpIO%LAI (I) + noahmp%energy%state%StemAreaIndex = NoahmpIO%XSAIXY (I) + noahmp%energy%state%SpecHumiditySfcMean = NoahmpIO%QSFC (I) + noahmp%energy%state%TemperatureGrd = NoahmpIO%TGXY (I) + noahmp%energy%state%TemperatureCanopy = NoahmpIO%TVXY (I) + noahmp%energy%state%SnowAgeNondim = NoahmpIO%TAUSSXY (I) + noahmp%energy%state%AlbedoSnowPrev = NoahmpIO%ALBOLDXY(I) + noahmp%energy%state%PressureVaporCanAir = NoahmpIO%EAHXY (I) + noahmp%energy%state%TemperatureCanopyAir = NoahmpIO%TAHXY (I) + noahmp%energy%state%ExchCoeffShSfc = NoahmpIO%CHXY (I) + noahmp%energy%state%ExchCoeffMomSfc = NoahmpIO%CMXY (I) + noahmp%energy%state%TemperatureSoilSnow(-NumSnowLayerMax+1:0) = NoahmpIO%TSNOXY (I,-NumSnowLayerMax+1:0) + noahmp%energy%state%TemperatureSoilSnow(1:NumSoilLayer) = NoahmpIO%TSLB (I,1:NumSoilLayer) + noahmp%energy%state%PressureAtmosCO2 = NoahmpIO%CO2_TABLE * noahmp%forcing%PressureAirRefHeight + noahmp%energy%state%PressureAtmosO2 = NoahmpIO%O2_TABLE * noahmp%forcing%PressureAirRefHeight + ! vegetation treatment for USGS land types (playa, lava, sand to bare) + if ( (VegType == 25) .or. (VegType == 26) .or. (VegType == 27) ) then + noahmp%energy%state%VegFrac = 0.0 + noahmp%energy%state%LeafAreaIndex = 0.0 + endif + + ! energy flux variables + noahmp%energy%flux%HeatGroundTotAcc = NoahmpIO%ACC_SSOILXY(I) + + ! energy parameter variables + noahmp%energy%param%SoilHeatCapacity = NoahmpIO%CSOIL_TABLE + noahmp%energy%param%SnowAgeFacBats = NoahmpIO%TAU0_TABLE + noahmp%energy%param%SnowGrowVapFacBats = NoahmpIO%GRAIN_GROWTH_TABLE + noahmp%energy%param%SnowSootFacBats = NoahmpIO%DIRT_SOOT_TABLE + noahmp%energy%param%SnowGrowFrzFacBats = NoahmpIO%EXTRA_GROWTH_TABLE + noahmp%energy%param%SolarZenithAdjBats = NoahmpIO%BATS_COSZ_TABLE + noahmp%energy%param%FreshSnoAlbVisBats = NoahmpIO%BATS_VIS_NEW_TABLE + noahmp%energy%param%FreshSnoAlbNirBats = NoahmpIO%BATS_NIR_NEW_TABLE + noahmp%energy%param%SnoAgeFacDifVisBats = NoahmpIO%BATS_VIS_AGE_TABLE + noahmp%energy%param%SnoAgeFacDifNirBats = NoahmpIO%BATS_NIR_AGE_TABLE + noahmp%energy%param%SzaFacDirVisBats = NoahmpIO%BATS_VIS_DIR_TABLE + noahmp%energy%param%SzaFacDirNirBats = NoahmpIO%BATS_NIR_DIR_TABLE + noahmp%energy%param%SnowAlbRefClass = NoahmpIO%CLASS_ALB_REF_TABLE + noahmp%energy%param%SnowAgeFacClass = NoahmpIO%CLASS_SNO_AGE_TABLE + noahmp%energy%param%SnowAlbFreshClass = NoahmpIO%CLASS_ALB_NEW_TABLE + noahmp%energy%param%UpscatterCoeffSnowDir = NoahmpIO%BETADS_TABLE + noahmp%energy%param%UpscatterCoeffSnowDif = NoahmpIO%BETAIS_TABLE + noahmp%energy%param%ZilitinkevichCoeff = NoahmpIO%CZIL_TABLE + noahmp%energy%param%EmissivitySnow = NoahmpIO%SNOW_EMIS_TABLE + noahmp%energy%param%EmissivitySoilLake = NoahmpIO%EG_TABLE + noahmp%energy%param%AlbedoLandIce = NoahmpIO%ALBICE_TABLE + noahmp%energy%param%RoughLenMomSnow = NoahmpIO%Z0SNO_TABLE + noahmp%energy%param%RoughLenMomSoil = NoahmpIO%Z0SOIL_TABLE + noahmp%energy%param%RoughLenMomLake = NoahmpIO%Z0LAKE_TABLE + noahmp%energy%param%EmissivityIceSfc = NoahmpIO%EICE_TABLE + noahmp%energy%param%ResistanceSoilExp = NoahmpIO%RSURF_EXP_TABLE + noahmp%energy%param%ResistanceSnowSfc = NoahmpIO%RSURF_SNOW_TABLE + noahmp%energy%param%VegFracAnnMax = NoahmpIO%GVFMAX(I) / 100.0 + noahmp%energy%param%VegFracGreen = NoahmpIO%VEGFRA(I) / 100.0 + noahmp%energy%param%TreeCrownRadius = NoahmpIO%RC_TABLE (VegType) + noahmp%energy%param%HeightCanopyTop = NoahmpIO%HVT_TABLE (VegType) + noahmp%energy%param%HeightCanopyBot = NoahmpIO%HVB_TABLE (VegType) + noahmp%energy%param%RoughLenMomVeg = NoahmpIO%Z0MVT_TABLE (VegType) + noahmp%energy%param%CanopyWindExtFac = NoahmpIO%CWPVT_TABLE (VegType) + noahmp%energy%param%TreeDensity = NoahmpIO%DEN_TABLE (VegType) + noahmp%energy%param%CanopyOrientIndex = NoahmpIO%XL_TABLE (VegType) + noahmp%energy%param%ConductanceLeafMin = NoahmpIO%BP_TABLE (VegType) + noahmp%energy%param%Co2MmConst25C = NoahmpIO%KC25_TABLE (VegType) + noahmp%energy%param%O2MmConst25C = NoahmpIO%KO25_TABLE (VegType) + noahmp%energy%param%Co2MmConstQ10 = NoahmpIO%AKC_TABLE (VegType) + noahmp%energy%param%O2MmConstQ10 = NoahmpIO%AKO_TABLE (VegType) + noahmp%energy%param%RadiationStressFac = NoahmpIO%RGL_TABLE (VegType) + noahmp%energy%param%ResistanceStomataMin = NoahmpIO%RS_TABLE (VegType) + noahmp%energy%param%ResistanceStomataMax = NoahmpIO%RSMAX_TABLE (VegType) + noahmp%energy%param%AirTempOptimTransp = NoahmpIO%TOPT_TABLE (VegType) + noahmp%energy%param%VaporPresDeficitFac = NoahmpIO%HS_TABLE (VegType) + noahmp%energy%param%LeafDimLength = NoahmpIO%DLEAF_TABLE (VegType) + noahmp%energy%param%HeatCapacCanFac = NoahmpIO%CBIOM_TABLE (VegType) + noahmp%energy%param%LeafAreaIndexMon (1:12) = NoahmpIO%LAIM_TABLE (VegType,1:12) + noahmp%energy%param%StemAreaIndexMon (1:12) = NoahmpIO%SAIM_TABLE (VegType,1:12) + noahmp%energy%param%ReflectanceLeaf (1:NumSwRadBand) = NoahmpIO%RHOL_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%ReflectanceStem (1:NumSwRadBand) = NoahmpIO%RHOS_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%TransmittanceLeaf(1:NumSwRadBand) = NoahmpIO%TAUL_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%TransmittanceStem(1:NumSwRadBand) = NoahmpIO%TAUS_TABLE (VegType,1:NumSwRadBand) + noahmp%energy%param%AlbedoSoilSat (1:NumSwRadBand) = NoahmpIO%ALBSAT_TABLE(SoilColor,1:NumSwRadBand) + noahmp%energy%param%AlbedoSoilDry (1:NumSwRadBand) = NoahmpIO%ALBDRY_TABLE(SoilColor,1:NumSwRadBand) + noahmp%energy%param%AlbedoLakeFrz (1:NumSwRadBand) = NoahmpIO%ALBLAK_TABLE(1:NumSwRadBand) + noahmp%energy%param%ScatterCoeffSnow (1:NumSwRadBand) = NoahmpIO%OMEGAS_TABLE(1:NumSwRadBand) + + do SoilLayerIndex = 1, size(SoilType) + noahmp%energy%param%SoilQuartzFrac(SoilLayerIndex) = NoahmpIO%QUARTZ_TABLE(SoilType(SoilLayerIndex)) + enddo + + ! spatial varying soil input + if ( noahmp%config%nmlist%OptSoilProperty == 4 ) then + noahmp%energy%param%SoilQuartzFrac(1:NumSoilLayer) = NoahmpIO%QUARTZ_3D(I,1:NumSoilLayer) + endif + + if ( FlagUrban .eqv. .true. ) noahmp%energy%param%SoilHeatCapacity = 3.0e6 + + if ( CropType > 0 ) then + noahmp%energy%param%ConductanceLeafMin = NoahmpIO%BPI_TABLE (CropType) + noahmp%energy%param%Co2MmConst25C = NoahmpIO%KC25I_TABLE(CropType) + noahmp%energy%param%O2MmConst25C = NoahmpIO%KO25I_TABLE(CropType) + noahmp%energy%param%Co2MmConstQ10 = NoahmpIO%AKCI_TABLE (CropType) + noahmp%energy%param%O2MmConstQ10 = NoahmpIO%AKOI_TABLE (CropType) + endif + + end associate + + end subroutine EnergyVarInTransfer + +end module EnergyVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 new file mode 100644 index 0000000000..377a7a8bb7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/EnergyVarOutTransferMod.F90 @@ -0,0 +1,188 @@ +module EnergyVarOutTransferMod + +!!! Transfer column (1-D) Noah-MP Energy variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine EnergyVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + + ! local variables + integer :: LoopInd ! snow/soil layer loop index + real(kind=kind_noahmp) :: LeafAreaIndSunlit ! sunlit leaf area index [m2/m2] + real(kind=kind_noahmp) :: LeafAreaIndShade ! shaded leaf area index [m2/m2] + real(kind=kind_noahmp) :: ResistanceLeafBoundary ! leaf boundary layer resistance [s/m] + real(kind=kind_noahmp) :: ThicknessSnowSoilLayer ! temporary snow/soil layer thickness [m] + +!----------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& + IndicatorIceSfc => noahmp%config%domain%IndicatorIceSfc & + ) +!----------------------------------------------------------------------- + + ! special treatment for glacier point output + if ( IndicatorIceSfc == -1 ) then ! land ice point + noahmp%energy%state%VegFrac = 0.0 + noahmp%energy%state%RoughLenMomSfcToAtm = 0.002 + noahmp%energy%flux%RadSwAbsVeg = 0.0 + noahmp%energy%flux%RadLwNetCanopy = 0.0 + noahmp%energy%flux%RadLwNetVegGrd = 0.0 + noahmp%energy%flux%HeatSensibleCanopy = 0.0 + noahmp%energy%flux%HeatSensibleVegGrd = 0.0 + noahmp%energy%flux%HeatLatentVegGrd = 0.0 + noahmp%energy%flux%HeatGroundVegGrd = 0.0 + noahmp%energy%flux%HeatCanStorageChg = 0.0 + noahmp%energy%flux%HeatLatentCanTransp = 0.0 + noahmp%energy%flux%HeatLatentCanEvap = 0.0 + noahmp%energy%flux%HeatPrecipAdvCanopy = 0.0 + noahmp%energy%flux%HeatPrecipAdvVegGrd = 0.0 + noahmp%energy%flux%HeatLatentCanopy = 0.0 + noahmp%energy%flux%HeatLatentTransp = 0.0 + noahmp%energy%flux%RadLwNetBareGrd = noahmp%energy%flux%RadLwNetSfc + noahmp%energy%flux%HeatSensibleBareGrd = noahmp%energy%flux%HeatSensibleSfc + noahmp%energy%flux%HeatLatentBareGrd = noahmp%energy%flux%HeatLatentGrd + noahmp%energy%flux%HeatGroundBareGrd = noahmp%energy%flux%HeatGroundTot + noahmp%energy%state%TemperatureGrdBare = noahmp%energy%state%TemperatureGrd + noahmp%energy%state%ExchCoeffShBare = noahmp%energy%state%ExchCoeffShSfc + NoahmpIO%LH(I) = noahmp%energy%flux%HeatLatentGrd + endif + + if ( IndicatorIceSfc == 0 ) then ! land soil point + NoahmpIO%LH(I) = noahmp%energy%flux%HeatLatentGrd + noahmp%energy%flux%HeatLatentCanopy + & + noahmp%energy%flux%HeatLatentTransp + noahmp%energy%flux%HeatLatentIrriEvap + endif + + ! energy flux variables + NoahmpIO%HFX (I) = noahmp%energy%flux%HeatSensibleSfc + NoahmpIO%GRDFLX (I) = noahmp%energy%flux%HeatGroundTot + NoahmpIO%FSAXY (I) = noahmp%energy%flux%RadSwAbsSfc + NoahmpIO%FIRAXY (I) = noahmp%energy%flux%RadLwNetSfc + NoahmpIO%APARXY (I) = noahmp%energy%flux%RadPhotoActAbsCan + NoahmpIO%SAVXY (I) = noahmp%energy%flux%RadSwAbsVeg + NoahmpIO%SAGXY (I) = noahmp%energy%flux%RadSwAbsGrd + NoahmpIO%IRCXY (I) = noahmp%energy%flux%RadLwNetCanopy + NoahmpIO%IRGXY (I) = noahmp%energy%flux%RadLwNetVegGrd + NoahmpIO%SHCXY (I) = noahmp%energy%flux%HeatSensibleCanopy + NoahmpIO%SHGXY (I) = noahmp%energy%flux%HeatSensibleVegGrd + NoahmpIO%EVGXY (I) = noahmp%energy%flux%HeatLatentVegGrd + NoahmpIO%GHVXY (I) = noahmp%energy%flux%HeatGroundVegGrd + NoahmpIO%IRBXY (I) = noahmp%energy%flux%RadLwNetBareGrd + NoahmpIO%SHBXY (I) = noahmp%energy%flux%HeatSensibleBareGrd + NoahmpIO%EVBXY (I) = noahmp%energy%flux%HeatLatentBareGrd + NoahmpIO%GHBXY (I) = noahmp%energy%flux%HeatGroundBareGrd + NoahmpIO%TRXY (I) = noahmp%energy%flux%HeatLatentCanTransp + NoahmpIO%EVCXY (I) = noahmp%energy%flux%HeatLatentCanEvap + NoahmpIO%CANHSXY (I) = noahmp%energy%flux%HeatCanStorageChg + NoahmpIO%PAHXY (I) = noahmp%energy%flux%HeatPrecipAdvSfc + NoahmpIO%PAHGXY (I) = noahmp%energy%flux%HeatPrecipAdvVegGrd + NoahmpIO%PAHVXY (I) = noahmp%energy%flux%HeatPrecipAdvCanopy + NoahmpIO%PAHBXY (I) = noahmp%energy%flux%HeatPrecipAdvBareGrd + NoahmpIO%ACC_SSOILXY(I) = noahmp%energy%flux%HeatGroundTotAcc + NoahmpIO%EFLXBXY (I) = noahmp%energy%flux%HeatFromSoilBot + + ! energy state variables + NoahmpIO%TSK (I) = noahmp%energy%state%TemperatureRadSfc + NoahmpIO%EMISS (I) = noahmp%energy%state%EmissivitySfc + NoahmpIO%QSFC (I) = noahmp%energy%state%SpecHumiditySfcMean + NoahmpIO%TVXY (I) = noahmp%energy%state%TemperatureCanopy + NoahmpIO%TGXY (I) = noahmp%energy%state%TemperatureGrd + NoahmpIO%EAHXY (I) = noahmp%energy%state%PressureVaporCanAir + NoahmpIO%TAHXY (I) = noahmp%energy%state%TemperatureCanopyAir + NoahmpIO%CMXY (I) = noahmp%energy%state%ExchCoeffMomSfc + NoahmpIO%CHXY (I) = noahmp%energy%state%ExchCoeffShSfc + NoahmpIO%ALBOLDXY(I) = noahmp%energy%state%AlbedoSnowPrev + NoahmpIO%LAI (I) = noahmp%energy%state%LeafAreaIndex + NoahmpIO%XSAIXY (I) = noahmp%energy%state%StemAreaIndex + NoahmpIO%TAUSSXY (I) = noahmp%energy%state%SnowAgeNondim + NoahmpIO%Z0 (I) = noahmp%energy%state%RoughLenMomSfcToAtm + NoahmpIO%ZNT (I) = noahmp%energy%state%RoughLenMomSfcToAtm + NoahmpIO%T2MVXY (I) = noahmp%energy%state%TemperatureAir2mVeg + NoahmpIO%T2MBXY (I) = noahmp%energy%state%TemperatureAir2mBare + NoahmpIO%TRADXY (I) = noahmp%energy%state%TemperatureRadSfc + NoahmpIO%FVEGXY (I) = noahmp%energy%state%VegFrac + NoahmpIO%RSSUNXY (I) = noahmp%energy%state%ResistanceStomataSunlit + NoahmpIO%RSSHAXY (I) = noahmp%energy%state%ResistanceStomataShade + NoahmpIO%BGAPXY (I) = noahmp%energy%state%GapBtwCanopy + NoahmpIO%WGAPXY (I) = noahmp%energy%state%GapInCanopy + NoahmpIO%TGVXY (I) = noahmp%energy%state%TemperatureGrdVeg + NoahmpIO%TGBXY (I) = noahmp%energy%state%TemperatureGrdBare + NoahmpIO%CHVXY (I) = noahmp%energy%state%ExchCoeffShAbvCan + NoahmpIO%CHBXY (I) = noahmp%energy%state%ExchCoeffShBare + NoahmpIO%CHLEAFXY(I) = noahmp%energy%state%ExchCoeffShLeaf + NoahmpIO%CHUCXY (I) = noahmp%energy%state%ExchCoeffShUndCan + NoahmpIO%CHV2XY (I) = noahmp%energy%state%ExchCoeffSh2mVeg + NoahmpIO%CHB2XY (I) = noahmp%energy%state%ExchCoeffSh2mBare + NoahmpIO%Q2MVXY (I) = noahmp%energy%state%SpecHumidity2mVeg /(1.0-noahmp%energy%state%SpecHumidity2mVeg) ! spec humidity to mixing ratio + NoahmpIO%Q2MBXY (I) = noahmp%energy%state%SpecHumidity2mBare/(1.0-noahmp%energy%state%SpecHumidity2mBare) + NoahmpIO%IRRSPLH (I) = NoahmpIO%IRRSPLH(I) + & + (noahmp%energy%flux%HeatLatentIrriEvap * noahmp%config%domain%MainTimeStep) + NoahmpIO%TSLB (I,1:NumSoilLayer) = noahmp%energy%state%TemperatureSoilSnow(1:NumSoilLayer) + NoahmpIO%TSNOXY (I,-NumSnowLayerMax+1:0) = noahmp%energy%state%TemperatureSoilSnow(-NumSnowLayerMax+1:0) + if ( noahmp%energy%state%AlbedoSfc > -999 ) then + NoahmpIO%ALBEDO(I) = noahmp%energy%state%AlbedoSfc + endif + + ! New Calculation of total Canopy/Stomatal Conductance Based on Bonan et al. (2011), Inverse of Canopy Resistance (below) + LeafAreaIndSunlit = max(noahmp%energy%state%LeafAreaIndSunlit, 0.0) + LeafAreaIndShade = max(noahmp%energy%state%LeafAreaIndShade, 0.0) + ResistanceLeafBoundary = max(noahmp%energy%state%ResistanceLeafBoundary, 0.0) + if ( (noahmp%energy%state%ResistanceStomataSunlit <= 0.0) .or. (noahmp%energy%state%ResistanceStomataShade <= 0.0) .or. & + (LeafAreaIndSunlit == 0.0) .or. (LeafAreaIndShade == 0.0) .or. & + (noahmp%energy%state%ResistanceStomataSunlit == undefined_real) .or. & + (noahmp%energy%state%ResistanceStomataShade == undefined_real) ) then + NoahmpIO%RS (I) = 0.0 + else + NoahmpIO%RS (I) = ((1.0 / (noahmp%energy%state%ResistanceStomataSunlit + ResistanceLeafBoundary) * & + noahmp%energy%state%LeafAreaIndSunlit) + & + ((1.0 / (noahmp%energy%state%ResistanceStomataShade + ResistanceLeafBoundary)) * & + noahmp%energy%state%LeafAreaIndShade)) + NoahmpIO%RS (I) = 1.0 / NoahmpIO%RS (I) ! Resistance + endif + + ! calculation of snow and soil energy storage + NoahmpIO%SNOWENERGY(I) = 0.0 + NoahmpIO%SOILENERGY(I) = 0.0 + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == NumSnowLayerNeg+1 ) then + ThicknessSnowSoilLayer = -noahmp%config%domain%DepthSnowSoilLayer(LoopInd) + else + ThicknessSnowSoilLayer = noahmp%config%domain%DepthSnowSoilLayer(LoopInd-1) - & + noahmp%config%domain%DepthSnowSoilLayer(LoopInd) + endif + if ( LoopInd >= 1 ) then + NoahmpIO%SOILENERGY(I) = NoahmpIO%SOILENERGY(I) + ThicknessSnowSoilLayer * & + noahmp%energy%state%HeatCapacSoilSnow(LoopInd) * & + (noahmp%energy%state%TemperatureSoilSnow(LoopInd) - 273.16) * 0.001 + else + NoahmpIO%SNOWENERGY(I) = NoahmpIO%SNOWENERGY(I) + ThicknessSnowSoilLayer * & + noahmp%energy%state%HeatCapacSoilSnow(LoopInd) * & + (noahmp%energy%state%TemperatureSoilSnow(LoopInd) - 273.16) * 0.001 + endif + enddo + + end associate + + end subroutine EnergyVarOutTransfer + +end module EnergyVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarInTransferMod.F90 new file mode 100644 index 0000000000..6ebf049f44 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarInTransferMod.F90 @@ -0,0 +1,68 @@ +module ForcingVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Forcing variables to 1-D column variable +!!! 1-D variables should be first defined in /src/ForcingVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine ForcingVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type), intent(inout) :: noahmp + + ! local variables + real(kind=kind_noahmp) :: PrecipOtherRefHeight ! other precipitation, e.g. fog [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipTotalRefHeight ! total precipitation [mm/s] at reference height + +! --------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI & + ) +! --------------------------------------------------------------- + + noahmp%forcing%TemperatureAirRefHeight = NoahmpIO%T_PHY(I,1) + noahmp%forcing%WindEastwardRefHeight = NoahmpIO%U_PHY(I,1) + noahmp%forcing%WindNorthwardRefHeight = NoahmpIO%V_PHY(I,1) + noahmp%forcing%SpecHumidityRefHeight = NoahmpIO%QV_CURR(I,1)/(1.0+NoahmpIO%QV_CURR(I,1)) ! convert from mixing ratio to specific humidity + noahmp%forcing%PressureAirRefHeight = (NoahmpIO%P8W(I,1) + NoahmpIO%P8W(I,2)) * 0.5 ! air pressure at middle point of lowest atmos model layer + noahmp%forcing%PressureAirSurface = NoahmpIO%P8W (I,1) + noahmp%forcing%RadLwDownRefHeight = NoahmpIO%GLW (I) + noahmp%forcing%RadSwDownRefHeight = NoahmpIO%SWDOWN (I) + noahmp%forcing%TemperatureSoilBottom = NoahmpIO%TMN (I) + + ! treat different precipitation types + PrecipTotalRefHeight = NoahmpIO%RAINBL (I) / NoahmpIO%DTBL ! convert precip unit from mm/timestep to mm/s + noahmp%forcing%PrecipConvRefHeight = NoahmpIO%MP_RAINC (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipNonConvRefHeight = NoahmpIO%MP_RAINNC(I) / NoahmpIO%DTBL + noahmp%forcing%PrecipShConvRefHeight = NoahmpIO%MP_SHCV (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipSnowRefHeight = NoahmpIO%MP_SNOW (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipGraupelRefHeight = NoahmpIO%MP_GRAUP (I) / NoahmpIO%DTBL + noahmp%forcing%PrecipHailRefHeight = NoahmpIO%MP_HAIL (I) / NoahmpIO%DTBL + ! treat other precipitation (e.g. fog) contained in total precipitation + PrecipOtherRefHeight = PrecipTotalRefHeight - noahmp%forcing%PrecipConvRefHeight - & + noahmp%forcing%PrecipNonConvRefHeight - noahmp%forcing%PrecipShConvRefHeight + PrecipOtherRefHeight = max(0.0, PrecipOtherRefHeight) + noahmp%forcing%PrecipNonConvRefHeight = noahmp%forcing%PrecipNonConvRefHeight + PrecipOtherRefHeight + noahmp%forcing%PrecipSnowRefHeight = noahmp%forcing%PrecipSnowRefHeight + PrecipOtherRefHeight * NoahmpIO%SR(I) + + end associate + + end subroutine ForcingVarInTransfer + +end module ForcingVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarOutTransferMod.F90 new file mode 100644 index 0000000000..2b5bd23fae --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/ForcingVarOutTransferMod.F90 @@ -0,0 +1,43 @@ +module ForcingVarOutTransferMod + +!!! Transfer column (1-D) Noah-MP forcing variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine ForcingVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI & + ) +! ------------------------------------------------------------------------- + + NoahmpIO%FORCTLSM (I) = noahmp%forcing%TemperatureAirRefHeight + NoahmpIO%FORCQLSM (I) = noahmp%forcing%SpecHumidityRefHeight + NoahmpIO%FORCPLSM (I) = noahmp%forcing%PressureAirRefHeight + NoahmpIO%FORCWLSM (I) = sqrt(noahmp%forcing%WindEastwardRefHeight**2 + & + noahmp%forcing%WindNorthwardRefHeight**2) + + end associate + + end subroutine ForcingVarOutTransfer + +end module ForcingVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile new file mode 100644 index 0000000000..5f816fff44 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/Makefile @@ -0,0 +1,74 @@ +.SUFFIXES: .o .F90 + +.PHONY: driver driver_lib + +all: dummy driver + +dummy: + echo "****** compiling physics_noahmp/drivers ******" + +OBJS = NoahmpSnowInitMod.o \ + NoahmpInitMainMod.o \ + NoahmpDriverMainMod.o \ + NoahmpIOVarType.o \ + NoahmpIOVarInitMod.o \ + NoahmpIOVarFinalizeMod.o \ + NoahmpReadTableMod.o \ + NoahmpReadNamelistMod.o \ + ConfigVarOutTransferMod.o \ + ForcingVarOutTransferMod.o \ + EnergyVarOutTransferMod.o \ + WaterVarOutTransferMod.o \ + BiochemVarOutTransferMod.o \ + ConfigVarInTransferMod.o \ + ForcingVarInTransferMod.o \ + EnergyVarInTransferMod.o \ + WaterVarInTransferMod.o \ + BiochemVarInTransferMod.o \ + PedoTransferSR2006Mod.o + +driver: $(OBJS) + +driver_lib: + ar -ru ./../../../libphys.a $(OBJS) + +# DEPENDENCIES: + +NoahmpIOVarType.o: ../../utility/Machine.o +NoahmpIOVarInitMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpIOVarFinalizeMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpReadTableMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpReadNamelistMod.o: ../../utility/Machine.o NoahmpIOVarType.o +PedoTransferSR2006Mod.o: ../../utility/Machine.o NoahmpIOVarType.o +ConfigVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +ForcingVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +EnergyVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +WaterVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +BiochemVarOutTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +ConfigVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +ForcingVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +EnergyVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +BiochemVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o +WaterVarInTransferMod.o: ../../utility/Machine.o NoahmpIOVarType.o ../../src/NoahmpVarType.o PedoTransferSR2006Mod.o +NoahmpSnowInitMod.o: ../../utility/Machine.o NoahmpIOVarType.o +NoahmpInitMainMod.o: ../../utility/Machine.o NoahmpIOVarType.o NoahmpSnowInitMod.o +NoahmpDriverMainMod.o: ../../utility/Machine.o ../../src/NoahmpVarType.o NoahmpIOVarType.o \ + ../../src/ConfigVarInitMod.o \ + ../../src/EnergyVarInitMod.o ../../src/ForcingVarInitMod.o \ + ../../src/WaterVarInitMod.o ../../src/BiochemVarInitMod.o \ + ../../src/NoahmpMainMod.o ../../src/NoahmpMainGlacierMod.o \ + ConfigVarOutTransferMod.o EnergyVarOutTransferMod.o \ + WaterVarOutTransferMod.o BiochemVarOutTransferMod.o \ + ForcingVarOutTransferMod.o ConfigVarInTransferMod.o \ + ForcingVarInTransferMod.o EnergyVarInTransferMod.o \ + WaterVarInTransferMod.o BiochemVarInTransferMod.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F90.o: + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I. -I../../utility -I../../src -I../../../../../framework -I../../../../../external/esmf_time_f90 + diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpDriverMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpDriverMainMod.F90 new file mode 100644 index 0000000000..2cbeb3bd26 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpDriverMainMod.F90 @@ -0,0 +1,231 @@ + module NoahmpDriverMainMod + + use Machine + use NoahmpVarType + use NoahmpIOVarType + use ConfigVarInitMod + use EnergyVarInitMod + use ForcingVarInitMod + use WaterVarInitMod + use BiochemVarInitMod + use ConfigVarInTransferMod + use EnergyVarInTransferMod + use ForcingVarInTransferMod + use WaterVarInTransferMod + use BiochemVarInTransferMod + use ConfigVarOutTransferMod + use ForcingVarOutTransferMod + use EnergyVarOutTransferMod + use WaterVarOutTransferMod + use BiochemVarOutTransferMod + use NoahmpMainMod + use NoahmpMainGlacierMod + + use mpas_log + + implicit none + + contains + + subroutine NoahmpDriverMain(NoahmpIO) + +! ------------------------ Code history ------------------------------------- +! Original Noah-MP subroutine: noahmplsm +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! --------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! local variables + type(noahmp_type) :: noahmp + integer :: i,k + integer :: jmonth,jday + real(kind=kind_noahmp) :: solar_time + real(kind=kind_noahmp), dimension( 1:NoahmpIO%nsoil ) :: sand + real(kind=kind_noahmp), dimension( 1:NoahmpIO%nsoil ) :: clay + real(kind=kind_noahmp), dimension( 1:NoahmpIO%nsoil ) :: orgm +! --------------------------------------------------------------------------- +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine NoahmpDriverMain:') + +!--------------------------------------------------------------------- +! Treatment of Noah-MP soil timestep +!--------------------------------------------------------------------- + NoahmpIO%calculate_soil = .false. + NoahmpIO%soil_update_steps = nint(NoahmpIO%soiltstep / NoahmpIO%dtbl) + NoahmpIO%soil_update_steps = max(NoahmpIO%soil_update_steps,1) + + if ( NoahmpIO%soil_update_steps == 1 ) then + NoahmpIO%acc_ssoilxy = 0.0 + NoahmpIO%acc_qinsurxy = 0.0 + NoahmpIO%acc_qsevaxy = 0.0 + NoahmpIO%acc_etranixy = 0.0 + NoahmpIO%acc_dwaterxy = 0.0 + NoahmpIO%acc_prcpxy = 0.0 + NoahmpIO%acc_ecanxy = 0.0 + NoahmpIO%acc_etranxy = 0.0 + NoahmpIO%acc_edirxy = 0.0 + endif + + if ( NoahmpIO%soil_update_steps > 1 ) then + if ( mod(NoahmpIO%itimestep, NoahmpIO%soil_update_steps) == 1 ) then + NoahmpIO%acc_ssoilxy = 0.0 + NoahmpIO%acc_qinsurxy = 0.0 + NoahmpIO%acc_qsevaxy = 0.0 + NoahmpIO%acc_etranixy = 0.0 + NoahmpIO%acc_dwaterxy = 0.0 + NoahmpIO%acc_prcpxy = 0.0 + NoahmpIO%acc_ecanxy = 0.0 + NoahmpIO%acc_etranxy = 0.0 + NoahmpIO%acc_edirxy = 0.0 + end if + endif + + if ( mod(NoahmpIO%itimestep, NoahmpIO%soil_update_steps) == 0 ) NoahmpIO%calculate_soil = .true. +!call mpas_log_write(' ') +!call mpas_log_write('--- enter subroutine noahmpdrivermain:') +!call mpas_log_write('--- NoahmpIO%itimestep = $i',intArgs=(/NoahmpIO%itimestep/)) +!call mpas_log_write('--- NoahmpIO%soiltstep = $r',realArgs=(/NoahmpIO%soiltstep/)) +!call mpas_log_write('--- NoahmpIO%dtbl = $r',realArgs=(/NoahmpIO%dtbl/)) +!call mpas_log_write('--- NoahmpIO%soil_update_steps = $i',intArgs=(/NoahmpIO%soil_update_steps/)) +!call mpas_log_write('--- NoahmpIO%calculate_soil = $l',logicArgs=(/NoahmpIO%calculate_soil/)) +!call mpas_log_write(' ') +!call mpas_log_write('--- NoahmpIO%isurban_table = $i',intArgs=(/NoahmpIO%isurban_table/)) +!call mpas_log_write('--- NoahmpIO%urbtype_beg = $i',intArgs=(/NoahmpIO%urbtype_beg/)) +!call mpas_log_write('--- NoahmpIO%sf_urban_physics = $i',intArgs=(/NoahmpIO%sf_urban_physics/)) +!call mpas_log_write('--- NoahmpIO%iri_urban = $i',intArgs=(/NoahmpIO%iri_urban/)) +!call mpas_log_write(' ') + +!--------------------------------------------------------------------- +! Prepare Noah-MP driver +!--------------------------------------------------------------------- + +! find length of year for phenology (also S Hemisphere): + NoahmpIO%yearlen = 365 + if (mod(NoahmpIO%yr,4) == 0)then + NoahmpIO%yearlen = 366 + if (mod(NoahmpIO%yr,100) == 0)then + NoahmpIO%yearlen = 365 + if (mod(NoahmpIO%yr,400) == 0)then + NoahmpIO%yearlen = 366 + endif + endif + endif + +! initialize jmonth and jday: + jmonth = NoahmpIO%month + jday = NoahmpIO%day +!call mpas_log_write('--- NoahmpIO%yearlen = $i',intargs=(/NoahmpIO%yearlen/)) +!call mpas_log_write('--- NoahmpIO%yr = $i',intargs=(/NoahmpIO%yr/)) +!call mpas_log_write('--- NoahmpIO%month = $i',intargs=(/jmonth/)) +!call mpas_log_write('--- NoahmpIO%day = $i',intargs=(/jday/)) +!call mpas_log_write('--- NoahmpIO%julian = $r',realargs=(/NoahmpIO%julian/)) +!call mpas_log_write('--- NoahmpIO%xice_threshold = $r',realargs=(/NoahmpIO%xice_threshold/)) +!call mpas_log_write(' ') + +! depth to soil interfaces (<0) [m] + NoahmpIO%zsoil(1) = -NoahmpIO%dzs(1) + do k = 2, NoahmpIO%nsoil + NoahmpIO%zsoil(k) = -NoahmpIO%dzs(k) + NoahmpIO%zsoil(k-1) + enddo + + if ( NoahmpIO%itimestep == 1 ) then + do i = NoahmpIO%its, NoahmpIO%ite + if ( (NoahmpIO%xland(i)-1.5) >= 0.0 ) then ! open water point + if ( NoahmpIO%xice(i) == 1.0 ) print*,' sea-ice at water point, i=',i + NoahmpIO%smstav(i) = 1.0 + NoahmpIO%smstot(i) = 1.0 + do k = 1, NoahmpIO%nsoil + NoahmpIO%smois(i,k) = 1.0 + NoahmpIO%tslb(i,k) = 273.16 + enddo + else + if ( NoahmpIO%xice(i) == 1.0 ) then ! sea-ice case + NoahmpIO%smstav(i) = 1.0 + NoahmpIO%smstot(i) = 1.0 + do k = 1, NoahmpIO%nsoil + NoahmpIO%smois(i,k) = 1.0 + enddo + endif + endif + enddo + endif ! end of initialization over ocean + + iloop : do i = NoahmpIO%its, NoahmpIO%ite + + NoahmpIO%j = 1 + NoahmpIO%i = i + if ( NoahmpIO%xice(i) >= NoahmpIO%xice_threshold ) then ! sea-ice point + NoahmpIO%ice = 1 + NoahmpIO%sh2o(i,1:NoahmpIO%nsoil) = 1.0 + NoahmpIO%lai (i) = 0.01 + cycle iloop ! skip any sea-ice points + else + if ( (NoahmpIO%xland(i)-1.5) >= 0.0 ) cycle ILOOP ! skip any open water points + !------------------------------------------------------------------------------------ + ! initialize Data Types and transfer all the inputs from 2-D to 1-D column variables + !------------------------------------------------------------------------------------ + call ConfigVarInitDefault (noahmp) + call ConfigVarInTransfer (noahmp, NoahmpIO) + call ForcingVarInitDefault (noahmp) + call ForcingVarInTransfer (noahmp, NoahmpIO) + call EnergyVarInitDefault (noahmp) + call EnergyVarInTransfer (noahmp, NoahmpIO) + call WaterVarInitDefault (noahmp) + call WaterVarInTransfer (noahmp, NoahmpIO) + call BiochemVarInitDefault (noahmp) + call BiochemVarInTransfer (noahmp, NoahmpIO) + + !---------------------------------------------------------------------- + ! hydrological processes for vegetation in urban model + ! irrigate vegetation only in urban area, MAY-SEP, 9-11pm + ! need to be separated from Noah-MP into outside urban specific module + !---------------------------------------------------------------------- + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isurban_table) .or. & + (NoahmpIO%ivgtyp(i) > NoahmpIO%urbtype_beg) ) then + if ( (NoahmpIO%sf_urban_physics > 0) .and. (NoahmpIO%iri_urban == 1) ) then + solar_time = (NoahmpIO%julian - int(NoahmpIO%julian))*24 + NoahmpIO%xlong(i)/15.0 + if ( solar_time < 0.0 ) solar_time = solar_time + 24.0 + if ( (solar_time >= 21.0) .and. (solar_time <= 23.0) .and. & + (jmonth >= 5) .and. (jmonth <= 9) ) then + noahmp%water%state%SoilMoisture(1) = & + max(noahmp%water%state%SoilMoisture(1),noahmp%water%param%SoilMoistureFieldCap(1)) + noahmp%water%state%SoilMoisture(2) = & + max(noahmp%water%state%SoilMoisture(2),noahmp%water%param%SoilMoistureFieldCap(2)) + endif + endif + endif + + !------------------------------------------------------------------------ + ! Call 1D Noah-MP LSM + !------------------------------------------------------------------------ + + if (noahmp%config%domain%VegType == noahmp%config%domain%IndexIcePoint ) then + noahmp%config%domain%IndicatorIceSfc = -1 ! Land-ice point + noahmp%forcing%TemperatureSoilBottom = min(noahmp%forcing%TemperatureSoilBottom,263.15) ! set deep glacier temp to >= -10C + call NoahmpMainGlacier(noahmp) + ! non-glacier land + else + noahmp%config%domain%IndicatorIceSfc = 0 ! land soil point. + call NoahmpMain(noahmp) + endif ! glacial split ends + + !--------------------------------------------------------------------- + ! Transfer 1-D Noah-MP column variables to 2-D output variables + !--------------------------------------------------------------------- + call ConfigVarOutTransfer (noahmp, NoahmpIO) + call ForcingVarOutTransfer(noahmp, NoahmpIO) + call EnergyVarOutTransfer (noahmp, NoahmpIO) + call WaterVarOutTransfer (noahmp, NoahmpIO) + call BiochemVarOutTransfer(noahmp, NoahmpIO) + + endif ! land-sea split ends + + enddo iloop ! i loop + + end subroutine NoahmpDriverMain + + end module NoahmpDriverMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpGroundwaterInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpGroundwaterInitMod.F90 new file mode 100644 index 0000000000..7bbf8c3fd3 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpGroundwaterInitMod.F90 @@ -0,0 +1,326 @@ +module NoahmpGroundwaterInitMod + +!!! Module to initialize Noah-MP Groundwater (GW) variables for MMF GW scheme + + use Machine + use NoahmpIOVarType + + implicit none + +contains + + subroutine NoahmpGroundwaterInitMain(grid, NoahmpIO) + +! ------------------------ Code history ------------------------------------- +! Original Noah-MP subroutine: GROUNDWATER_INIT +! Original code: Miguez-Macho, Fan et al. (2007) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! --------------------------------------------------------------------------- + + use GroundWaterMmfMod, only : LATERALFLOW + use module_domain, only : domain + +#if (EM_CORE == 1) +#ifdef DM_PARALLEL + use module_dm , only : ntasks_x,ntasks_y,local_communicator,mytask,ntasks + use module_comm_dm, only : halo_em_hydro_noahmp_sub +#endif +#endif + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(domain), target :: grid + + ! local variables + logical :: urbanpt_flag ! added to identify urban pixels + integer :: I,J,K,ITER,itf,jtf,NITER,NCOUNT,NS + real(kind=kind_noahmp) :: BEXP,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT + real(kind=kind_noahmp) :: FRLIQ,SMCEQDEEP + real(kind=kind_noahmp) :: DELTAT,RCOND,TOTWATER + real(kind=kind_noahmp) :: AA,BBB,CC,DD,DX,FUNC,DFUNC,DDZ,EXPON,SMC,FLUX + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL) :: SMCEQ,ZSOIL + real(kind=kind_noahmp), dimension(NoahmpIO%ims:NoahmpIO%ime, NoahmpIO%jms:NoahmpIO%jme) :: QLAT, QRF + ! landmask: -1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations + integer, dimension(NoahmpIO%ims:NoahmpIO%ime, NoahmpIO%jms:NoahmpIO%jme) :: LANDMASK + +! -------------------------------------------------------------------------------- + associate( & + ids => NoahmpIO%ids ,& + ide => NoahmpIO%ide ,& + jds => NoahmpIO%jds ,& + jde => NoahmpIO%jde ,& + kds => NoahmpIO%kds ,& + kde => NoahmpIO%kde ,& + ims => NoahmpIO%ims ,& + ime => NoahmpIO%ime ,& + jms => NoahmpIO%jms ,& + jme => NoahmpIO%jme ,& + kms => NoahmpIO%kms ,& + kme => NoahmpIO%kme ,& + ips => NoahmpIO%ims ,& + ipe => NoahmpIO%ime ,& + jps => NoahmpIO%jms ,& + jpe => NoahmpIO%jme ,& + kps => NoahmpIO%kms ,& + kpe => NoahmpIO%kme ,& + its => NoahmpIO%its ,& + ite => NoahmpIO%ite ,& + jts => NoahmpIO%jts ,& + jte => NoahmpIO%jte ,& + kts => NoahmpIO%kts ,& + kte => NoahmpIO%kte & + ) +! -------------------------------------------------------------------------------- + + ! Given the soil layer thicknesses (in DZS), calculate the soil layer depths from the surface. + ZSOIL(1) = -NoahmpIO%DZS(1) ! negative + do NS = 2, NoahmpIO%NSOIL + ZSOIL(NS) = ZSOIL(NS-1) - NoahmpIO%DZS(NS) + enddo + + ! initialize grid index + itf = min0(ite,(ide+1)-1) + jtf = min0(jte,(jde+1)-1) + + ! initialize land mask + where ( (NoahmpIO%IVGTYP /= NoahmpIO%ISWATER_TABLE) .and. (NoahmpIO%IVGTYP /= NoahmpIO%ISICE_TABLE) ) + LANDMASK = 1 + elsewhere + LANDMASK = -1 + endwhere + + NoahmpIO%PEXPXY = 1.0 + DELTAT = 365.0*24*3600.0 ! 1 year + + ! read just the raw aggregated water table from hi-res map, so that it is better compatible with topography + ! use WTD here, to use the lateral communication routine + NoahmpIO%ZWTXY = NoahmpIO%EQZWT + NCOUNT = 0 + + do NITER = 1, 500 +#if (EM_CORE == 1) +#ifdef DM_PARALLEL +# include "HALO_EM_HYDRO_NOAHMP.inc" +#endif +#endif + ! Calculate lateral flow + if ( (NCOUNT > 0) .or. (NITER == 1) ) then + QLAT = 0.0 + call LATERALFLOW(NoahmpIO,NoahmpIO%ISLTYP,NoahmpIO%ZWTXY,QLAT,NoahmpIO%FDEPTHXY,& + NoahmpIO%TERRAIN,LANDMASK,DELTAT,NoahmpIO%AREAXY, & + ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte ) + NCOUNT = 0 + do J = jts, jtf + do I = its, itf + if ( LANDMASK(I,J) > 0 ) then + if ( QLAT(i,j) > 1.0e-2 ) then + NCOUNT = NCOUNT + 1 + NoahmpIO%ZWTXY(I,J) = min(NoahmpIO%ZWTXY(I,J)+0.25, 0.0) + endif + endif + enddo + enddo + + endif + enddo !NITER + +#if (EM_CORE == 1) +#ifdef DM_PARALLEL +# include "HALO_EM_HYDRO_NOAHMP.inc" +#endif +#endif + + NoahmpIO%EQZWT=NoahmpIO%ZWTXY + + ! after adjusting, where qlat > 1cm/year now wtd is at the surface. + ! it may still happen that qlat + rech > 0 and eqwtd-rbed <0. There the wtd can + ! rise to the surface (poor drainage) but the et will then increase. + + ! now, calculate river conductivity + do J = jts, jtf + do I = its, itf + DDZ = NoahmpIO%EQZWT(I,J) - (NoahmpIO%RIVERBEDXY(I,J) - NoahmpIO%TERRAIN(I,J)) + ! dont allow riverbed above water table + if ( DDZ < 0.0 ) then + NoahmpIO%RIVERBEDXY(I,J) = NoahmpIO%TERRAIN(I,J) + NoahmpIO%EQZWT(I,J) + DDZ = 0.0 + endif + TOTWATER = NoahmpIO%AREAXY(I,J) * (QLAT(I,J) + NoahmpIO%RECHCLIM(I,J)*0.001) / DELTAT + if ( TOTWATER > 0 ) then + NoahmpIO%RIVERCONDXY(I,J) = TOTWATER / max(DDZ,0.05) + else + NoahmpIO%RIVERCONDXY(I,J) = 0.01 + ! make riverbed equal to eqwtd, otherwise qrf might be too big... + NoahmpIO%RIVERBEDXY(I,J) = NoahmpIO%TERRAIN(I,J) + NoahmpIO%EQZWT(I,J) + endif + enddo + enddo + + ! make riverbed to be height down from the surface instead of above sea level + NoahmpIO%RIVERBEDXY = min(NoahmpIO%RIVERBEDXY-NoahmpIO%TERRAIN, 0.0) + + ! now recompute lateral flow and flow to rivers to initialize deep soil moisture + DELTAT = NoahmpIO%WTDDT * 60.0 !timestep in seconds for this calculation + QLAT = 0.0 + call LATERALFLOW(NoahmpIO,NoahmpIO%ISLTYP,NoahmpIO%ZWTXY,QLAT,NoahmpIO%FDEPTHXY,& + NoahmpIO%TERRAIN,LANDMASK,DELTAT,NoahmpIO%AREAXY, & + ids,ide,jds,jde,kds,kde,ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte ) + + ! compute flux from grounwater to rivers in the cell + do J = jts, jtf + do I = its, itf + if ( LANDMASK(I,J) > 0 ) then + if ( (NoahmpIO%ZWTXY(I,J) > NoahmpIO%RIVERBEDXY(I,J)) .and. & + (NoahmpIO%EQZWT(I,J) > NoahmpIO%RIVERBEDXY(I,J)) ) then + RCOND = NoahmpIO%RIVERCONDXY(I,J) * exp(NoahmpIO%PEXPXY(I,J)*(NoahmpIO%ZWTXY(I,J)-NoahmpIO%EQZWT(I,J))) + else + RCOND = NoahmpIO%RIVERCONDXY(I,J) + endif + QRF(I,J) = RCOND * (NoahmpIO%ZWTXY(I,J)-NoahmpIO%RIVERBEDXY(I,J)) * DELTAT / NoahmpIO%AREAXY(I,J) + ! for now, dont allow it to go from river to groundwater + QRF(I,J) = max(QRF(I,J), 0.0) + else + QRF(I,J) = 0.0 + endif + enddo + enddo + + ! now compute eq. soil moisture, change soil moisture to be compatible with the water table and compute deep soil moisture + do J = jts, jtf + do I = its, itf + + BEXP = NoahmpIO%BEXP_TABLE(NoahmpIO%ISLTYP(I,J)) + SMCMAX = NoahmpIO%SMCMAX_TABLE(NoahmpIO%ISLTYP(I,J)) + SMCWLT = NoahmpIO%SMCWLT_TABLE(NoahmpIO%ISLTYP(I,J)) + ! add urban flag + urbanpt_flag = .false. + if ( (NoahmpIO%IVGTYP(I,J) == NoahmpIO%ISURBAN_TABLE) .or. & + (NoahmpIO%IVGTYP(I,J) > NoahmpIO%URBTYPE_beg) ) urbanpt_flag = .true. + if ( urbanpt_flag .eqv. .true. ) then + SMCMAX = 0.45 + SMCWLT = 0.40 + endif + DWSAT = NoahmpIO%DWSAT_TABLE(NoahmpIO%ISLTYP(I,J)) + DKSAT = NoahmpIO%DKSAT_TABLE(NoahmpIO%ISLTYP(I,J)) + PSISAT = -NoahmpIO%PSISAT_TABLE(NoahmpIO%ISLTYP(I,J)) + if ( (BEXP > 0.0) .and. (SMCMAX > 0.0) .and. (-PSISAT > 0.0) ) then + ! initialize equilibrium soil moisture for water table diagnostic + call EquilibriumSoilMoisture(NoahmpIO%NSOIL, ZSOIL, SMCMAX, SMCWLT, DWSAT, DKSAT, BEXP, SMCEQ) + NoahmpIO%SMOISEQ(I,1:NoahmpIO%NSOIL,J) = SMCEQ(1:NoahmpIO%NSOIL) + + ! make sure that below the water table the layers are saturated and + ! initialize the deep soil moisture + if ( NoahmpIO%ZWTXY(I,J) < (ZSOIL(NoahmpIO%NSOIL)-NoahmpIO%DZS(NoahmpIO%NSOIL)) ) then + ! initialize deep soil moisture so that the flux compensates qlat+qrf + ! use Newton-Raphson method to find soil moisture + EXPON = 2.0 * BEXP + 3.0 + DDZ = ZSOIL(NoahmpIO%NSOIL) - NoahmpIO%ZWTXY(I,J) + CC = PSISAT / DDZ + FLUX = (QLAT(I,J) - QRF(I,J)) / DELTAT + SMC = 0.5 * SMCMAX + do ITER = 1, 100 + DD = (SMC + SMCMAX) / (2.0*SMCMAX) + AA = -DKSAT * DD ** EXPON + BBB = CC * ((SMCMAX / SMC)**BEXP - 1.0) + 1.0 + FUNC = AA * BBB - FLUX + DFUNC = -DKSAT * (EXPON / (2.0*SMCMAX)) * DD ** (EXPON - 1.0) * BBB & + + AA * CC * (-BEXP) * SMCMAX ** BEXP * SMC ** (-BEXP-1.0) + DX = FUNC / DFUNC + SMC = SMC - DX + if ( abs(DX) < 1.0e-6 ) exit + enddo + NoahmpIO%SMCWTDXY(I,J) = max(SMC, 1.0e-4) + elseif ( NoahmpIO%ZWTXY(I,J) < ZSOIL(NoahmpIO%NSOIL) ) then + SMCEQDEEP = SMCMAX * (PSISAT / (PSISAT - NoahmpIO%DZS(NoahmpIO%NSOIL))) ** (1.0/BEXP) + !SMCEQDEEP = MAX(SMCEQDEEP,SMCWLT) + SMCEQDEEP = max(SMCEQDEEP, 1.0e-4) + NoahmpIO%SMCWTDXY(I,J) = SMCMAX * (NoahmpIO%ZWTXY(I,J)-(ZSOIL(NoahmpIO%NSOIL)-NoahmpIO%DZS(NoahmpIO%NSOIL))) + & + SMCEQDEEP * (ZSOIL(NoahmpIO%NSOIL) - NoahmpIO%ZWTXY(I,J)) + else !water table within the resolved layers + NoahmpIO%SMCWTDXY(I,J) = SMCMAX + do K = NoahmpIO%NSOIL, 2, -1 + if ( NoahmpIO%ZWTXY(I,J) >= ZSOIL(K-1) ) then + FRLIQ = NoahmpIO%SH2O(I,K,J) / NoahmpIO%SMOIS(I,K,J) + NoahmpIO%SMOIS(I,K,J) = SMCMAX + NoahmpIO%SH2O(I,K,J) = SMCMAX * FRLIQ + else + if ( NoahmpIO%SMOIS(I,K,J) < SMCEQ(K) ) then + NoahmpIO%ZWTXY(I,J) = ZSOIL(K) + else + NoahmpIO%ZWTXY(I,J) = (NoahmpIO%SMOIS(I,K,J)*NoahmpIO%DZS(K) - SMCEQ(K)*ZSOIL(K-1) + & + SMCMAX*ZSOIL(K)) / (SMCMAX - SMCEQ(K)) + endif + exit + endif + enddo + endif + else + NoahmpIO%SMOISEQ (I,1:NoahmpIO%NSOIL,J) = SMCMAX + NoahmpIO%SMCWTDXY(I,J) = SMCMAX + NoahmpIO%ZWTXY(I,J) = 0.0 + endif + + ! zero out some arrays + NoahmpIO%QLATXY(I,J) = 0.0 + NoahmpIO%QSLATXY(I,J) = 0.0 + NoahmpIO%QRFXY(I,J) = 0.0 + NoahmpIO%QRFSXY(I,J) = 0.0 + NoahmpIO%DEEPRECHXY(I,J) = 0.0 + NoahmpIO%RECHXY(I,J) = 0.0 + NoahmpIO%QSPRINGXY(I,J) = 0.0 + NoahmpIO%QSPRINGSXY(I,J) = 0.0 + + enddo + enddo + + end associate + + end subroutine NoahmpGroundwaterInitMain + + subroutine EquilibriumSoilMoisture(NSOIL, ZSOIL, SMCMAX, SMCWLT, DWSAT, DKSAT, BEXP, SMCEQ) + + implicit none + + integer, intent(in) :: NSOIL !no. of soil layers + real(kind=kind_noahmp), intent(in) :: SMCMAX , SMCWLT, BEXP , DWSAT, DKSAT + real(kind=kind_noahmp), dimension(1:NSOIL), intent(in) :: ZSOIL !depth of soil layer-bottom [m] + real(kind=kind_noahmp), dimension(1:NSOIL), intent(out) :: SMCEQ !equilibrium soil water content [m3/m3] + + ! local variables + integer :: K, ITER + real(kind=kind_noahmp) :: DDZ, SMC, FUNC, DFUNC, AA, BB, EXPON, DX + ! -------------------------------------------------------------------------------- + + ! gmm compute equilibrium soil moisture content for the layer when wtd=zsoil(k) + do K = 1, NSOIL + if ( K == 1 ) then + DDZ = -ZSOIL(K+1) * 0.5 + elseif ( K < NSOIL ) then + DDZ = ( ZSOIL(K-1) - ZSOIL(K+1) ) * 0.5 + else + DDZ = ZSOIL(K-1) - ZSOIL(K) + endif + + ! use Newton-Raphson method to find eq soil moisture + EXPON = BEXP + 1.0 + AA = DWSAT / DDZ + BB = DKSAT / SMCMAX ** EXPON + SMC = 0.5 * SMCMAX + do ITER = 1, 100 + FUNC = (SMC - SMCMAX) * AA + BB * SMC ** EXPON + DFUNC = AA + BB * EXPON * SMC ** BEXP + DX = FUNC / DFUNC + SMC = SMC - DX + if ( abs(DX) < 1.0e-6 ) exit + enddo + +! SMCEQ(K) = min(max(SMC,SMCWLT),SMCMAX*0.99) + SMCEQ(K) = min(max(SMC,1.0e-4), SMCMAX*0.99) + enddo + + end subroutine EquilibriumSoilMoisture + +end module NoahmpGroundwaterInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarFinalizeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarFinalizeMod.F90 new file mode 100644 index 0000000000..12df9b1909 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarFinalizeMod.F90 @@ -0,0 +1,463 @@ +module NoahmpIOVarFinalizeMod + +!!! Initialize Noah-MP input/output variables +!!! Input/Output variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== initialize with default values + + subroutine NoahmpIOVarFinalizeDefault(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------- + associate( & + nsoil => NoahmpIO%nsoil ,& + nsnow => NoahmpIO%nsnow & + ) +! ------------------------------------------------- + + ! Input variables + if ( allocated (NoahmpIO%coszen) ) deallocate ( NoahmpIO%coszen ) ! cosine zenith angle + if ( allocated (NoahmpIO%xlat) ) deallocate ( NoahmpIO%xlat ) ! latitude [radians] + if ( allocated (NoahmpIO%dzs) ) deallocate ( NoahmpIO%dzs ) ! thickness of soil layers [m] + if ( allocated (NoahmpIO%zsoil) ) deallocate ( NoahmpIO%zsoil ) ! depth to soil interfaces [m] + if ( allocated (NoahmpIO%ivgtyp) ) deallocate ( NoahmpIO%ivgtyp ) ! vegetation type + if ( allocated (NoahmpIO%isltyp) ) deallocate ( NoahmpIO%isltyp ) ! soil type + if ( allocated (NoahmpIO%vegfra) ) deallocate ( NoahmpIO%vegfra ) ! vegetation fraction [] + if ( allocated (NoahmpIO%tmn) ) deallocate ( NoahmpIO%tmn ) ! deep soil temperature [K] + if ( allocated (NoahmpIO%xland) ) deallocate ( NoahmpIO%xland ) ! =2 ocean; =1 land/seaice + if ( allocated (NoahmpIO%xice) ) deallocate ( NoahmpIO%xice ) ! fraction of grid that is seaice + if ( allocated (NoahmpIO%swdown) ) deallocate ( NoahmpIO%swdown ) ! solar down at surface [W m-2] + if ( allocated (NoahmpIO%swddir) ) deallocate ( NoahmpIO%swddir ) ! solar down at surface [W m-2] for new urban solar panel + if ( allocated (NoahmpIO%swddif) ) deallocate ( NoahmpIO%swddif ) ! solar down at surface [W m-2] for new urban solar panel + if ( allocated (NoahmpIO%glw) ) deallocate ( NoahmpIO%glw ) ! longwave down at surface [W m-2] + if ( allocated (NoahmpIO%rainbl) ) deallocate ( NoahmpIO%rainbl ) ! total precipitation entering land model [mm] per time step + if ( allocated (NoahmpIO%snowbl) ) deallocate ( NoahmpIO%snowbl ) ! snow entering land model [mm] per time step + if ( allocated (NoahmpIO%sr) ) deallocate ( NoahmpIO%sr ) ! frozen precip ratio entering land model [-] + if ( allocated (NoahmpIO%raincv) ) deallocate ( NoahmpIO%raincv ) ! convective precip forcing [mm] + if ( allocated (NoahmpIO%rainncv) ) deallocate ( NoahmpIO%rainncv ) ! non-convective precip forcing [mm] + if ( allocated (NoahmpIO%rainshv) ) deallocate ( NoahmpIO%rainshv ) ! shallow conv. precip forcing [mm] + if ( allocated (NoahmpIO%snowncv) ) deallocate ( NoahmpIO%snowncv ) ! non-covective snow forcing (subset of rainncv) [mm] + if ( allocated (NoahmpIO%graupelncv)) deallocate ( NoahmpIO%graupelncv ) ! non-convective graupel forcing (subset of rainncv) [mm] + if ( allocated (NoahmpIO%hailncv) ) deallocate ( NoahmpIO%hailncv ) ! non-convective hail forcing (subset of rainncv) [mm] + if ( allocated (NoahmpIO%mp_rainc) ) deallocate ( NoahmpIO%mp_rainc ) ! convective precip forcing [mm] + if ( allocated (NoahmpIO%mp_rainnc) ) deallocate ( NoahmpIO%mp_rainnc ) ! non-convective precip forcing [mm] + if ( allocated (NoahmpIO%mp_shcv) ) deallocate ( NoahmpIO%mp_shcv ) ! shallow conv. precip forcing [mm] + if ( allocated (NoahmpIO%mp_snow) ) deallocate ( NoahmpIO%mp_snow ) ! non-covective snow (subset of rainnc) [mm] + if ( allocated (NoahmpIO%mp_graup) ) deallocate ( NoahmpIO%mp_graup ) ! non-convective graupel (subset of rainnc) [mm] + if ( allocated (NoahmpIO%mp_hail) ) deallocate ( NoahmpIO%mp_hail ) ! non-convective hail (subset of rainnc) [mm] + if ( allocated (NoahmpIO%seaice) ) deallocate ( NoahmpIO%seaice ) ! seaice fraction + if ( allocated (NoahmpIO%dz8w) ) deallocate ( NoahmpIO%dz8w ) ! thickness of atmo layers [m] + if ( allocated (NoahmpIO%t_phy) ) deallocate ( NoahmpIO%t_phy ) ! 3d atmospheric temperature valid at mid-levels [K] + if ( allocated (NoahmpIO%qv_curr) ) deallocate ( NoahmpIO%qv_curr ) ! 3d water vapor mixing ratio [kg/kg_dry] + if ( allocated (NoahmpIO%u_phy) ) deallocate ( NoahmpIO%u_phy ) ! 3d u wind component [m/s] + if ( allocated (NoahmpIO%v_phy) ) deallocate ( NoahmpIO%v_phy ) ! 3d v wind component [m/s] + if ( allocated (NoahmpIO%p8w) ) deallocate ( NoahmpIO%p8w ) ! 3d pressure, valid at interface [Pa] + + ! spatial varying parameter map + if ( NoahmpIO%iopt_soil > 1 ) then + if ( allocated (NoahmpIO%soilcomp)) deallocate ( NoahmpIO%soilcomp ) ! soil sand and clay content [fraction] + if ( allocated (NoahmpIO%soilcl1) ) deallocate ( NoahmpIO%soilcl1 ) ! soil texture class with depth + if ( allocated (NoahmpIO%soilcl2) ) deallocate ( NoahmpIO%soilcl2 ) ! soil texture class with depth + if ( allocated (NoahmpIO%soilcl3) ) deallocate ( NoahmpIO%soilcl3 ) ! soil texture class with depth + if ( allocated (NoahmpIO%soilcl4) ) deallocate ( NoahmpIO%soilcl4 ) ! soil texture class with depth + endif + if ( NoahmpIO%iopt_soil == 4 ) then + if ( allocated (NoahmpIO%bexp_3d) ) deallocate ( NoahmpIO%bexp_3d ) ! c-h b exponent + if ( allocated (NoahmpIO%smcdry_3d) ) deallocate ( NoahmpIO%smcdry_3d ) ! soil moisture limit: dry + if ( allocated (NoahmpIO%smcwlt_3d) ) deallocate ( NoahmpIO%smcwlt_3d ) ! soil moisture limit: wilt + if ( allocated (NoahmpIO%smcref_3d) ) deallocate ( NoahmpIO%smcref_3d ) ! soil moisture limit: reference + if ( allocated (NoahmpIO%smcmax_3d) ) deallocate ( NoahmpIO%smcmax_3d ) ! soil moisture limit: max + if ( allocated (NoahmpIO%dksat_3d) ) deallocate ( NoahmpIO%dksat_3d ) ! saturated soil conductivity + if ( allocated (NoahmpIO%dwsat_3d) ) deallocate ( NoahmpIO%dwsat_3d ) ! saturated soil diffusivity + if ( allocated (NoahmpIO%psisat_3d) ) deallocate ( NoahmpIO%psisat_3d ) ! saturated matric potential + if ( allocated (NoahmpIO%quartz_3d) ) deallocate ( NoahmpIO%quartz_3d ) ! soil quartz content + if ( allocated (NoahmpIO%refdk_2d) ) deallocate ( NoahmpIO%refdk_2d ) ! reference soil conductivity + if ( allocated (NoahmpIO%refkdt_2d) ) deallocate ( NoahmpIO%refkdt_2d ) ! soil infiltration parameter + if ( allocated (NoahmpIO%irr_frac_2d) ) deallocate ( NoahmpIO%irr_frac_2d ) ! irrigation fraction + if ( allocated (NoahmpIO%irr_har_2d) ) deallocate ( NoahmpIO%irr_har_2d ) ! number of days before harvest date to stop irrigation + if ( allocated (NoahmpIO%irr_lai_2d) ) deallocate ( NoahmpIO%irr_lai_2d ) ! minimum lai to trigger irrigation + if ( allocated (NoahmpIO%irr_mad_2d) ) deallocate ( NoahmpIO%irr_mad_2d ) ! management allowable deficit (0-1) + if ( allocated (NoahmpIO%filoss_2d) ) deallocate ( NoahmpIO%filoss_2d ) ! fraction of flood irrigation loss (0-1) + if ( allocated (NoahmpIO%sprir_rate_2d)) deallocate ( NoahmpIO%sprir_rate_2d ) ! mm/h, sprinkler irrigation rate + if ( allocated (NoahmpIO%micir_rate_2d)) deallocate ( NoahmpIO%micir_rate_2d ) ! mm/h, micro irrigation rate + if ( allocated (NoahmpIO%firtfac_2d) ) deallocate ( NoahmpIO%firtfac_2d ) ! flood application rate factor + if ( allocated (NoahmpIO%ir_rain_2d) ) deallocate ( NoahmpIO%ir_rain_2d ) ! maximum precipitation to stop irrigation trigger + if ( allocated (NoahmpIO%bvic_2d) ) deallocate ( NoahmpIO%bvic_2d ) ! VIC model infiltration parameter [-] + if ( allocated (NoahmpIO%axaj_2d) ) deallocate ( NoahmpIO%axaj_2d ) ! tension water distribution inflection parameter [-] + if ( allocated (NoahmpIO%bxaj_2d) ) deallocate ( NoahmpIO%bxaj_2d ) ! tension water distribution shape parameter [-] + if ( allocated (NoahmpIO%xxaj_2d) ) deallocate ( NoahmpIO%xxaj_2d ) ! free water distribution shape parameter [-] + if ( allocated (NoahmpIO%bdvic_2d) ) deallocate ( NoahmpIO%bdvic_2d ) ! DVIC model infiltration parameter [-] + if ( allocated (NoahmpIO%gdvic_2d) ) deallocate ( NoahmpIO%gdvic_2d ) ! mean capillary drive (m) for infiltration models + if ( allocated (NoahmpIO%bbvic_2d) ) deallocate ( NoahmpIO%bbvic_2d ) ! dvic heterogeniety parameter for infiltration [-] + if ( allocated (NoahmpIO%klat_fac) ) deallocate ( NoahmpIO%klat_fac ) ! factor multiplier to hydraulic conductivity + if ( allocated (NoahmpIO%tdsmc_fac) ) deallocate ( NoahmpIO%tdsmc_fac ) ! factor multiplier to field capacity + if ( allocated (NoahmpIO%td_dc) ) deallocate ( NoahmpIO%td_dc ) ! drainage coefficient for simple + if ( allocated (NoahmpIO%td_dcoef) ) deallocate ( NoahmpIO%td_dcoef ) ! drainage coefficient for Hooghoudt + if ( allocated (NoahmpIO%td_ddrain) ) deallocate ( NoahmpIO%td_ddrain ) ! depth of drain + if ( allocated (NoahmpIO%td_radi) ) deallocate ( NoahmpIO%td_radi ) ! tile radius + if ( allocated (NoahmpIO%td_spac) ) deallocate ( NoahmpIO%td_spac ) ! tile spacing + endif + + ! INOUT (with generic LSM equivalent) (as defined in WRF) + if ( allocated (NoahmpIO%tsk) ) deallocate ( NoahmpIO%tsk ) ! surface radiative temperature [K] + if ( allocated (NoahmpIO%hfx) ) deallocate ( NoahmpIO%hfx ) ! sensible heat flux [W m-2] + if ( allocated (NoahmpIO%qfx) ) deallocate ( NoahmpIO%qfx ) ! latent heat flux [kg s-1 m-2] + if ( allocated (NoahmpIO%lh) ) deallocate ( NoahmpIO%lh ) ! latent heat flux [W m-2] + if ( allocated (NoahmpIO%grdflx) ) deallocate ( NoahmpIO%grdflx ) ! ground/snow heat flux [W m-2] + if ( allocated (NoahmpIO%smstav) ) deallocate ( NoahmpIO%smstav ) ! soil moisture avail. [not used] + if ( allocated (NoahmpIO%smstot) ) deallocate ( NoahmpIO%smstot ) ! total soil water [mm][not used] + if ( allocated (NoahmpIO%sfcrunoff)) deallocate ( NoahmpIO%sfcrunoff ) ! accumulated surface runoff [m] + if ( allocated (NoahmpIO%udrunoff) ) deallocate ( NoahmpIO%udrunoff ) ! accumulated sub-surface runoff [m] + if ( allocated (NoahmpIO%albedo) ) deallocate ( NoahmpIO%albedo ) ! total grid albedo [] + if ( allocated (NoahmpIO%snowc) ) deallocate ( NoahmpIO%snowc ) ! snow cover fraction [] + if ( allocated (NoahmpIO%snow) ) deallocate ( NoahmpIO%snow ) ! snow water equivalent [mm] + if ( allocated (NoahmpIO%snowh) ) deallocate ( NoahmpIO%snowh ) ! physical snow depth [m] + if ( allocated (NoahmpIO%canwat) ) deallocate ( NoahmpIO%canwat ) ! total canopy water + ice [mm] + if ( allocated (NoahmpIO%acsnom) ) deallocate ( NoahmpIO%acsnom ) ! accumulated snow melt leaving pack + if ( allocated (NoahmpIO%acsnow) ) deallocate ( NoahmpIO%acsnow ) ! accumulated snow on grid + if ( allocated (NoahmpIO%emiss) ) deallocate ( NoahmpIO%emiss ) ! surface bulk emissivity + if ( allocated (NoahmpIO%qsfc) ) deallocate ( NoahmpIO%qsfc ) ! bulk surface specific humidity + if ( allocated (NoahmpIO%smoiseq) ) deallocate ( NoahmpIO%smoiseq ) ! equilibrium volumetric soil moisture [m3/m3] + if ( allocated (NoahmpIO%smois) ) deallocate ( NoahmpIO%smois ) ! volumetric soil moisture [m3/m3] + if ( allocated (NoahmpIO%sh2o) ) deallocate ( NoahmpIO%sh2o ) ! volumetric liquid soil moisture [m3/m3] + if ( allocated (NoahmpIO%tslb) ) deallocate ( NoahmpIO%tslb ) ! soil temperature [K] + + ! INOUT (with no Noah LSM equivalent) (as defined in WRF) + if ( allocated (NoahmpIO%isnowxy) ) deallocate ( NoahmpIO%isnowxy ) ! actual no. of snow layers + if ( allocated (NoahmpIO%tvxy) ) deallocate ( NoahmpIO%tvxy ) ! vegetation leaf temperature + if ( allocated (NoahmpIO%tgxy) ) deallocate ( NoahmpIO%tgxy ) ! bulk ground surface temperature + if ( allocated (NoahmpIO%canicexy) ) deallocate ( NoahmpIO%canicexy ) ! canopy-intercepted ice (mm) + if ( allocated (NoahmpIO%canliqxy) ) deallocate ( NoahmpIO%canliqxy ) ! canopy-intercepted liquid water (mm) + if ( allocated (NoahmpIO%eahxy) ) deallocate ( NoahmpIO%eahxy ) ! canopy air vapor pressure (Pa) + if ( allocated (NoahmpIO%tahxy) ) deallocate ( NoahmpIO%tahxy ) ! canopy air temperature (K) + if ( allocated (NoahmpIO%cmxy) ) deallocate ( NoahmpIO%cmxy ) ! bulk momentum drag coefficient + if ( allocated (NoahmpIO%chxy) ) deallocate ( NoahmpIO%chxy ) ! bulk sensible heat exchange coefficient + if ( allocated (NoahmpIO%fwetxy) ) deallocate ( NoahmpIO%fwetxy ) ! wetted or snowed fraction of the canopy (-) + if ( allocated (NoahmpIO%sneqvoxy) ) deallocate ( NoahmpIO%sneqvoxy ) ! snow mass at last time step(mm H2O) + if ( allocated (NoahmpIO%alboldxy) ) deallocate ( NoahmpIO%alboldxy ) ! snow albedo at last time step (-) + if ( allocated (NoahmpIO%qsnowxy) ) deallocate ( NoahmpIO%qsnowxy ) ! snowfall on the ground [mm/s] + if ( allocated (NoahmpIO%qrainxy) ) deallocate ( NoahmpIO%qrainxy ) ! rainfall on the ground [mm/s] + if ( allocated (NoahmpIO%wslakexy) ) deallocate ( NoahmpIO%wslakexy ) ! lake water storage [mm] + if ( allocated (NoahmpIO%zwtxy) ) deallocate ( NoahmpIO%zwtxy ) ! water table depth [m] + if ( allocated (NoahmpIO%waxy) ) deallocate ( NoahmpIO%waxy ) ! water in the "aquifer" [mm] + if ( allocated (NoahmpIO%wtxy) ) deallocate ( NoahmpIO%wtxy ) ! groundwater storage [mm] + if ( allocated (NoahmpIO%smcwtdxy) ) deallocate ( NoahmpIO%smcwtdxy ) ! soil moisture below the bottom of the column (m3 m-3) + if ( allocated (NoahmpIO%deeprechxy)) deallocate ( NoahmpIO%deeprechxy ) ! recharge to the water table when deep (m) + if ( allocated (NoahmpIO%rechxy) ) deallocate ( NoahmpIO%rechxy ) ! recharge to the water table (diagnostic) (m) + if ( allocated (NoahmpIO%lfmassxy) ) deallocate ( NoahmpIO%lfmassxy ) ! leaf mass [g/m2] + if ( allocated (NoahmpIO%rtmassxy) ) deallocate ( NoahmpIO%rtmassxy ) ! mass of fine roots [g/m2] + if ( allocated (NoahmpIO%stmassxy) ) deallocate ( NoahmpIO%stmassxy ) ! stem mass [g/m2] + if ( allocated (NoahmpIO%woodxy) ) deallocate ( NoahmpIO%woodxy ) ! mass of wood (incl. woody roots) [g/m2] + if ( allocated (NoahmpIO%grainxy) ) deallocate ( NoahmpIO%grainxy ) ! mass of grain xing [g/m2] + if ( allocated (NoahmpIO%gddxy) ) deallocate ( NoahmpIO%gddxy ) ! growing degree days xing four + if ( allocated (NoahmpIO%stblcpxy) ) deallocate ( NoahmpIO%stblcpxy ) ! stable carbon in deep soil [g/m2] + if ( allocated (NoahmpIO%fastcpxy) ) deallocate ( NoahmpIO%fastcpxy ) ! short-lived carbon, shallow soil [g/m2] + if ( allocated (NoahmpIO%lai) ) deallocate ( NoahmpIO%lai ) ! leaf area index + if ( allocated (NoahmpIO%xsaixy) ) deallocate ( NoahmpIO%xsaixy ) ! stem area index + if ( allocated (NoahmpIO%taussxy) ) deallocate ( NoahmpIO%taussxy ) ! snow age factor + if ( allocated (NoahmpIO%tsnoxy) ) deallocate ( NoahmpIO%tsnoxy ) ! snow temperature [K] + if ( allocated (NoahmpIO%zsnsoxy) ) deallocate ( NoahmpIO%zsnsoxy ) ! snow layer depth [m] + if ( allocated (NoahmpIO%snicexy) ) deallocate ( NoahmpIO%snicexy ) ! snow layer ice [mm] + if ( allocated (NoahmpIO%snliqxy) ) deallocate ( NoahmpIO%snliqxy ) ! snow layer liquid water [mm] + + ! irrigation + if ( allocated (NoahmpIO%irfract) ) deallocate ( NoahmpIO%irfract ) ! irrigation fraction + if ( allocated (NoahmpIO%sifract) ) deallocate ( NoahmpIO%sifract ) ! sprinkler irrigation fraction + if ( allocated (NoahmpIO%mifract) ) deallocate ( NoahmpIO%mifract ) ! micro irrigation fraction + if ( allocated (NoahmpIO%fifract) ) deallocate ( NoahmpIO%fifract ) ! flood irrigation fraction + if ( allocated (NoahmpIO%irnumsi) ) deallocate ( NoahmpIO%irnumsi ) ! irrigation event number, sprinkler + if ( allocated (NoahmpIO%irnummi) ) deallocate ( NoahmpIO%irnummi ) ! irrigation event number, micro + if ( allocated (NoahmpIO%irnumfi) ) deallocate ( NoahmpIO%irnumfi ) ! irrigation event number, flood + if ( allocated (NoahmpIO%irwatsi) ) deallocate ( NoahmpIO%irwatsi ) ! irrigation water amount [m] to be applied, sprinkler + if ( allocated (NoahmpIO%irwatmi) ) deallocate ( NoahmpIO%irwatmi ) ! irrigation water amount [m] to be applied, micro + if ( allocated (NoahmpIO%irwatfi) ) deallocate ( NoahmpIO%irwatfi ) ! irrigation water amount [m] to be applied, flood + if ( allocated (NoahmpIO%ireloss) ) deallocate ( NoahmpIO%ireloss ) ! loss of irrigation water to evaporation,sprinkler [mm] + if ( allocated (NoahmpIO%irsivol) ) deallocate ( NoahmpIO%irsivol ) ! amount of irrigation by sprinkler (mm) + if ( allocated (NoahmpIO%irmivol) ) deallocate ( NoahmpIO%irmivol ) ! amount of irrigation by micro (mm) + if ( allocated (NoahmpIO%irfivol) ) deallocate ( NoahmpIO%irfivol ) ! amount of irrigation by micro (mm) + if ( allocated (NoahmpIO%irrsplh) ) deallocate ( NoahmpIO%irrsplh ) ! latent heating from sprinkler evaporation (W/m2) + if ( allocated (NoahmpIO%loctim) ) deallocate ( NoahmpIO%loctim ) ! local time + + ! OUT (with no Noah LSM equivalent) (as defined in WRF) + if ( allocated (NoahmpIO%t2mvxy) ) deallocate ( NoahmpIO%t2mvxy ) ! 2m temperature of vegetation part + if ( allocated (NoahmpIO%t2mbxy) ) deallocate ( NoahmpIO%t2mbxy ) ! 2m temperature of bare ground part + if ( allocated (NoahmpIO%q2mvxy) ) deallocate ( NoahmpIO%q2mvxy ) ! 2m mixing ratio of vegetation part + if ( allocated (NoahmpIO%q2mbxy) ) deallocate ( NoahmpIO%q2mbxy ) ! 2m mixing ratio of bare ground part + if ( allocated (NoahmpIO%tradxy) ) deallocate ( NoahmpIO%tradxy ) ! surface radiative temperature (K) + if ( allocated (NoahmpIO%neexy) ) deallocate ( NoahmpIO%neexy ) ! net ecosys exchange (g/m2/s CO2) + if ( allocated (NoahmpIO%gppxy) ) deallocate ( NoahmpIO%gppxy ) ! gross primary assimilation [g/m2/s C] + if ( allocated (NoahmpIO%nppxy) ) deallocate ( NoahmpIO%nppxy ) ! net primary productivity [g/m2/s C] + if ( allocated (NoahmpIO%fvegxy) ) deallocate ( NoahmpIO%fvegxy ) ! noah-mp vegetation fraction [-] + if ( allocated (NoahmpIO%runsfxy) ) deallocate ( NoahmpIO%runsfxy ) ! surface runoff [mm per soil timestep] + if ( allocated (NoahmpIO%runsbxy) ) deallocate ( NoahmpIO%runsbxy ) ! subsurface runoff [mm per soil timestep] + if ( allocated (NoahmpIO%ecanxy) ) deallocate ( NoahmpIO%ecanxy ) ! evaporation of intercepted water (mm/s) + if ( allocated (NoahmpIO%edirxy) ) deallocate ( NoahmpIO%edirxy ) ! soil surface evaporation rate (mm/s] + if ( allocated (NoahmpIO%etranxy) ) deallocate ( NoahmpIO%etranxy ) ! transpiration rate (mm/s) + if ( allocated (NoahmpIO%fsaxy) ) deallocate ( NoahmpIO%fsaxy ) ! total absorbed solar radiation (W/m2) + if ( allocated (NoahmpIO%firaxy) ) deallocate ( NoahmpIO%firaxy ) ! total net longwave rad (W/m2) [+ to atm] + if ( allocated (NoahmpIO%aparxy) ) deallocate ( NoahmpIO%aparxy ) ! photosyn active energy by canopy (W/m2) + if ( allocated (NoahmpIO%psnxy) ) deallocate ( NoahmpIO%psnxy ) ! total photosynthesis (umol CO2/m2/s) [+] + if ( allocated (NoahmpIO%savxy) ) deallocate ( NoahmpIO%savxy ) ! solar rad absorbed by veg. (W/m2) + if ( allocated (NoahmpIO%sagxy) ) deallocate ( NoahmpIO%sagxy ) ! solar rad absorbed by ground (W/m2) + if ( allocated (NoahmpIO%rssunxy) ) deallocate ( NoahmpIO%rssunxy ) ! sunlit leaf stomatal resistance (s/m) + if ( allocated (NoahmpIO%rsshaxy) ) deallocate ( NoahmpIO%rsshaxy ) ! shaded leaf stomatal resistance (s/m) + if ( allocated (NoahmpIO%bgapxy) ) deallocate ( NoahmpIO%bgapxy ) ! between gap fraction + if ( allocated (NoahmpIO%wgapxy) ) deallocate ( NoahmpIO%wgapxy ) ! within gap fraction + if ( allocated (NoahmpIO%tgvxy) ) deallocate ( NoahmpIO%tgvxy ) ! under canopy ground temperature[K] + if ( allocated (NoahmpIO%tgbxy) ) deallocate ( NoahmpIO%tgbxy ) ! bare ground temperature [K] + if ( allocated (NoahmpIO%chvxy) ) deallocate ( NoahmpIO%chvxy ) ! sensible heat exchange coefficient vegetated + if ( allocated (NoahmpIO%chbxy) ) deallocate ( NoahmpIO%chbxy ) ! sensible heat exchange coefficient bare-ground + if ( allocated (NoahmpIO%shgxy) ) deallocate ( NoahmpIO%shgxy ) ! veg ground sen. heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%shcxy) ) deallocate ( NoahmpIO%shcxy ) ! canopy sen. heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%shbxy) ) deallocate ( NoahmpIO%shbxy ) ! bare sensible heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%evgxy) ) deallocate ( NoahmpIO%evgxy ) ! veg ground evap. heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%evbxy) ) deallocate ( NoahmpIO%evbxy ) ! bare soil evaporation [W/m2] [+ to atm] + if ( allocated (NoahmpIO%ghvxy) ) deallocate ( NoahmpIO%ghvxy ) ! veg ground heat flux [W/m2] [+ to soil] + if ( allocated (NoahmpIO%ghbxy) ) deallocate ( NoahmpIO%ghbxy ) ! bare ground heat flux [W/m2] [+ to soil] + if ( allocated (NoahmpIO%irgxy) ) deallocate ( NoahmpIO%irgxy ) ! veg ground net lw rad. [W/m2] [+ to atm] + if ( allocated (NoahmpIO%ircxy) ) deallocate ( NoahmpIO%ircxy ) ! canopy net lw rad. [W/m2] [+ to atm] + if ( allocated (NoahmpIO%irbxy) ) deallocate ( NoahmpIO%irbxy ) ! bare net longwave rad. [W/m2] [+ to atm] + if ( allocated (NoahmpIO%trxy) ) deallocate ( NoahmpIO%trxy ) ! transpiration [w/m2] [+ to atm] + if ( allocated (NoahmpIO%evcxy) ) deallocate ( NoahmpIO%evcxy ) ! canopy evaporation heat [W/m2] [+ to atm] + if ( allocated (NoahmpIO%chleafxy) ) deallocate ( NoahmpIO%chleafxy ) ! leaf exchange coefficient + if ( allocated (NoahmpIO%chucxy) ) deallocate ( NoahmpIO%chucxy ) ! under canopy exchange coefficient + if ( allocated (NoahmpIO%chv2xy) ) deallocate ( NoahmpIO%chv2xy ) ! veg 2m exchange coefficient + if ( allocated (NoahmpIO%chb2xy) ) deallocate ( NoahmpIO%chb2xy ) ! bare 2m exchange coefficient + if ( allocated (NoahmpIO%rs) ) deallocate ( NoahmpIO%rs ) ! total stomatal resistance (s/m) + if ( allocated (NoahmpIO%z0) ) deallocate ( NoahmpIO%z0 ) ! roughness length output to WRF + if ( allocated (NoahmpIO%znt) ) deallocate ( NoahmpIO%znt ) ! roughness length output to WRF + if ( allocated (NoahmpIO%qtdrain) ) deallocate ( NoahmpIO%qtdrain ) ! tile drainage (mm) + if ( allocated (NoahmpIO%td_fraction)) deallocate ( NoahmpIO%td_fraction ) ! tile drainage fraction + if ( allocated (NoahmpIO%xlong) ) deallocate ( NoahmpIO%xlong ) ! longitude + if ( allocated (NoahmpIO%terrain) ) deallocate ( NoahmpIO%terrain ) ! terrain height + if ( allocated (NoahmpIO%gvfmin) ) deallocate ( NoahmpIO%gvfmin ) ! annual minimum in vegetation fraction + if ( allocated (NoahmpIO%gvfmax) ) deallocate ( NoahmpIO%gvfmax ) ! annual maximum in vegetation fraction + + ! additional output variables + if ( allocated (NoahmpIO%pahxy) ) deallocate ( NoahmpIO%pahxy ) + if ( allocated (NoahmpIO%pahgxy) ) deallocate ( NoahmpIO%pahgxy ) + if ( allocated (NoahmpIO%pahbxy) ) deallocate ( NoahmpIO%pahbxy ) + if ( allocated (NoahmpIO%pahvxy) ) deallocate ( NoahmpIO%pahvxy ) + if ( allocated (NoahmpIO%qintsxy) ) deallocate ( NoahmpIO%qintsxy ) + if ( allocated (NoahmpIO%qintrxy) ) deallocate ( NoahmpIO%qintrxy ) + if ( allocated (NoahmpIO%qdripsxy) ) deallocate ( NoahmpIO%qdripsxy ) + if ( allocated (NoahmpIO%qdriprxy) ) deallocate ( NoahmpIO%qdriprxy ) + if ( allocated (NoahmpIO%qthrosxy) ) deallocate ( NoahmpIO%qthrosxy ) + if ( allocated (NoahmpIO%qthrorxy) ) deallocate ( NoahmpIO%qthrorxy ) + if ( allocated (NoahmpIO%qsnsubxy) ) deallocate ( NoahmpIO%qsnsubxy ) + if ( allocated (NoahmpIO%qsnfroxy) ) deallocate ( NoahmpIO%qsnfroxy ) + if ( allocated (NoahmpIO%qsubcxy) ) deallocate ( NoahmpIO%qsubcxy ) + if ( allocated (NoahmpIO%qfrocxy) ) deallocate ( NoahmpIO%qfrocxy ) + if ( allocated (NoahmpIO%qevacxy) ) deallocate ( NoahmpIO%qevacxy ) + if ( allocated (NoahmpIO%qdewcxy) ) deallocate ( NoahmpIO%qdewcxy ) + if ( allocated (NoahmpIO%qfrzcxy) ) deallocate ( NoahmpIO%qfrzcxy ) + if ( allocated (NoahmpIO%qmeltcxy) ) deallocate ( NoahmpIO%qmeltcxy ) + if ( allocated (NoahmpIO%qsnbotxy) ) deallocate ( NoahmpIO%qsnbotxy ) + if ( allocated (NoahmpIO%qmeltxy) ) deallocate ( NoahmpIO%qmeltxy ) + if ( allocated (NoahmpIO%pondingxy) ) deallocate ( NoahmpIO%pondingxy ) + if ( allocated (NoahmpIO%fpicexy) ) deallocate ( NoahmpIO%fpicexy ) + if ( allocated (NoahmpIO%rainlsm) ) deallocate ( NoahmpIO%rainlsm ) + if ( allocated (NoahmpIO%snowlsm) ) deallocate ( NoahmpIO%snowlsm ) + if ( allocated (NoahmpIO%forctlsm) ) deallocate ( NoahmpIO%forctlsm ) + if ( allocated (NoahmpIO%forcqlsm) ) deallocate ( NoahmpIO%forcqlsm ) + if ( allocated (NoahmpIO%forcplsm) ) deallocate ( NoahmpIO%forcplsm ) + if ( allocated (NoahmpIO%forczlsm) ) deallocate ( NoahmpIO%forczlsm ) + if ( allocated (NoahmpIO%forcwlsm) ) deallocate ( NoahmpIO%forcwlsm ) + if ( allocated (NoahmpIO%eflxbxy) ) deallocate ( NoahmpIO%eflxbxy ) + if ( allocated (NoahmpIO%soilenergy) ) deallocate ( NoahmpIO%soilenergy ) + if ( allocated (NoahmpIO%snowenergy) ) deallocate ( NoahmpIO%snowenergy ) + if ( allocated (NoahmpIO%canhsxy) ) deallocate ( NoahmpIO%canhsxy ) + if ( allocated (NoahmpIO%acc_dwaterxy)) deallocate ( NoahmpIO%acc_dwaterxy ) + if ( allocated (NoahmpIO%acc_prcpxy) ) deallocate ( NoahmpIO%acc_prcpxy ) + if ( allocated (NoahmpIO%acc_ecanxy) ) deallocate ( NoahmpIO%acc_ecanxy ) + if ( allocated (NoahmpIO%acc_etranxy) ) deallocate ( NoahmpIO%acc_etranxy ) + if ( allocated (NoahmpIO%acc_edirxy) ) deallocate ( NoahmpIO%acc_edirxy ) + if ( allocated (NoahmpIO%acc_ssoilxy) ) deallocate ( NoahmpIO%acc_ssoilxy ) + if ( allocated (NoahmpIO%acc_qinsurxy)) deallocate ( NoahmpIO%acc_qinsurxy ) + if ( allocated (NoahmpIO%acc_qsevaxy) ) deallocate ( NoahmpIO%acc_qsevaxy ) + if ( allocated (NoahmpIO%acc_etranixy)) deallocate ( NoahmpIO%acc_etranixy ) + + ! needed for mmf_runoff (iopt_run = 5); not part of mp driver in WRF + if ( allocated (NoahmpIO%msftx) ) deallocate ( NoahmpIO%msftx ) + if ( allocated (NoahmpIO%msfty) ) deallocate ( NoahmpIO%msfty ) + if ( allocated (NoahmpIO%eqzwt) ) deallocate ( NoahmpIO%eqzwt ) + if ( allocated (NoahmpIO%riverbedxy) ) deallocate ( NoahmpIO%riverbedxy ) + if ( allocated (NoahmpIO%rivercondxy)) deallocate ( NoahmpIO%rivercondxy ) + if ( allocated (NoahmpIO%pexpxy) ) deallocate ( NoahmpIO%pexpxy ) + if ( allocated (NoahmpIO%fdepthxy) ) deallocate ( NoahmpIO%fdepthxy ) + if ( allocated (NoahmpIO%areaxy) ) deallocate ( NoahmpIO%areaxy ) + if ( allocated (NoahmpIO%qrfsxy) ) deallocate ( NoahmpIO%qrfsxy ) + if ( allocated (NoahmpIO%qspringsxy) ) deallocate ( NoahmpIO%qspringsxy ) + if ( allocated (NoahmpIO%qrfxy) ) deallocate ( NoahmpIO%qrfxy ) + if ( allocated (NoahmpIO%qspringxy) ) deallocate ( NoahmpIO%qspringxy ) + if ( allocated (NoahmpIO%qslatxy) ) deallocate ( NoahmpIO%qslatxy ) + if ( allocated (NoahmpIO%qlatxy) ) deallocate ( NoahmpIO%qlatxy ) + if ( allocated (NoahmpIO%rechclim) ) deallocate ( NoahmpIO%rechclim ) + if ( allocated (NoahmpIO%rivermask) ) deallocate ( NoahmpIO%rivermask ) + if ( allocated (NoahmpIO%nonriverxy) ) deallocate ( NoahmpIO%nonriverxy ) + + ! needed for crop model (opt_crop=1) + if ( allocated (NoahmpIO%pgsxy) ) deallocate ( NoahmpIO%pgsxy ) + if ( allocated (NoahmpIO%cropcat) ) deallocate ( NoahmpIO%cropcat ) + if ( allocated (NoahmpIO%planting) ) deallocate ( NoahmpIO%planting ) + if ( allocated (NoahmpIO%harvest) ) deallocate ( NoahmpIO%harvest ) + if ( allocated (NoahmpIO%season_gdd)) deallocate ( NoahmpIO%season_gdd ) + if ( allocated (NoahmpIO%croptype) ) deallocate ( NoahmpIO%croptype ) + + ! Single- and Multi-layer Urban Models + if ( NoahmpIO%sf_urban_physics > 0 ) then + if ( allocated (NoahmpIO%sh_urb2d) ) deallocate ( NoahmpIO%sh_urb2d ) + if ( allocated (NoahmpIO%lh_urb2d) ) deallocate ( NoahmpIO%lh_urb2d ) + if ( allocated (NoahmpIO%g_urb2d) ) deallocate ( NoahmpIO%g_urb2d ) + if ( allocated (NoahmpIO%rn_urb2d) ) deallocate ( NoahmpIO%rn_urb2d ) + if ( allocated (NoahmpIO%ts_urb2d) ) deallocate ( NoahmpIO%ts_urb2d ) + if ( allocated (NoahmpIO%hrang) ) deallocate ( NoahmpIO%hrang ) + if ( allocated (NoahmpIO%frc_urb2d) ) deallocate ( NoahmpIO%frc_urb2d ) + if ( allocated (NoahmpIO%utype_urb2d)) deallocate ( NoahmpIO%utype_urb2d ) + if ( allocated (NoahmpIO%lp_urb2d) ) deallocate ( NoahmpIO%lp_urb2d ) + if ( allocated (NoahmpIO%lb_urb2d) ) deallocate ( NoahmpIO%lb_urb2d ) + if ( allocated (NoahmpIO%hgt_urb2d) ) deallocate ( NoahmpIO%hgt_urb2d ) + if ( allocated (NoahmpIO%ust) ) deallocate ( NoahmpIO%ust ) + endif + + if(NoahmpIO%sf_urban_physics == 1 ) then ! single layer urban model + if ( allocated (NoahmpIO%cmr_sfcdif) ) deallocate ( NoahmpIO%cmr_sfcdif ) + if ( allocated (NoahmpIO%chr_sfcdif) ) deallocate ( NoahmpIO%chr_sfcdif ) + if ( allocated (NoahmpIO%cmc_sfcdif) ) deallocate ( NoahmpIO%cmc_sfcdif ) + if ( allocated (NoahmpIO%chc_sfcdif) ) deallocate ( NoahmpIO%chc_sfcdif ) + if ( allocated (NoahmpIO%cmgr_sfcdif) ) deallocate ( NoahmpIO%cmgr_sfcdif ) + if ( allocated (NoahmpIO%chgr_sfcdif) ) deallocate ( NoahmpIO%chgr_sfcdif ) + if ( allocated (NoahmpIO%tr_urb2d) ) deallocate ( NoahmpIO%tr_urb2d ) + if ( allocated (NoahmpIO%tb_urb2d) ) deallocate ( NoahmpIO%tb_urb2d ) + if ( allocated (NoahmpIO%tg_urb2d) ) deallocate ( NoahmpIO%tg_urb2d ) + if ( allocated (NoahmpIO%tc_urb2d) ) deallocate ( NoahmpIO%tc_urb2d ) + if ( allocated (NoahmpIO%qc_urb2d) ) deallocate ( NoahmpIO%qc_urb2d ) + if ( allocated (NoahmpIO%uc_urb2d) ) deallocate ( NoahmpIO%uc_urb2d ) + if ( allocated (NoahmpIO%xxxr_urb2d) ) deallocate ( NoahmpIO%xxxr_urb2d ) + if ( allocated (NoahmpIO%xxxb_urb2d) ) deallocate ( NoahmpIO%xxxb_urb2d ) + if ( allocated (NoahmpIO%xxxg_urb2d) ) deallocate ( NoahmpIO%xxxg_urb2d ) + if ( allocated (NoahmpIO%xxxc_urb2d) ) deallocate ( NoahmpIO%xxxc_urb2d ) + if ( allocated (NoahmpIO%psim_urb2d) ) deallocate ( NoahmpIO%psim_urb2d ) + if ( allocated (NoahmpIO%psih_urb2d) ) deallocate ( NoahmpIO%psih_urb2d ) + if ( allocated (NoahmpIO%u10_urb2d) ) deallocate ( NoahmpIO%u10_urb2d ) + if ( allocated (NoahmpIO%v10_urb2d) ) deallocate ( NoahmpIO%v10_urb2d ) + if ( allocated (NoahmpIO%gz1oz0_urb2d) ) deallocate ( NoahmpIO%gz1oz0_urb2d ) + if ( allocated (NoahmpIO%akms_urb2d) ) deallocate ( NoahmpIO%akms_urb2d ) + if ( allocated (NoahmpIO%th2_urb2d) ) deallocate ( NoahmpIO%th2_urb2d ) + if ( allocated (NoahmpIO%q2_urb2d) ) deallocate ( NoahmpIO%q2_urb2d ) + if ( allocated (NoahmpIO%ust_urb2d) ) deallocate ( NoahmpIO%ust_urb2d ) + if ( allocated (NoahmpIO%cmcr_urb2d) ) deallocate ( NoahmpIO%cmcr_urb2d ) + if ( allocated (NoahmpIO%tgr_urb2d) ) deallocate ( NoahmpIO%tgr_urb2d ) + if ( allocated (NoahmpIO%drelr_urb2d) ) deallocate ( NoahmpIO%drelr_urb2d ) + if ( allocated (NoahmpIO%drelb_urb2d) ) deallocate ( NoahmpIO%drelb_urb2d ) + if ( allocated (NoahmpIO%drelg_urb2d) ) deallocate ( NoahmpIO%drelg_urb2d ) + if ( allocated (NoahmpIO%flxhumr_urb2d)) deallocate ( NoahmpIO%flxhumr_urb2d ) + if ( allocated (NoahmpIO%flxhumb_urb2d)) deallocate ( NoahmpIO%flxhumb_urb2d ) + if ( allocated (NoahmpIO%flxhumg_urb2d)) deallocate ( NoahmpIO%flxhumg_urb2d ) + if ( allocated (NoahmpIO%chs) ) deallocate ( NoahmpIO%chs ) + if ( allocated (NoahmpIO%chs2) ) deallocate ( NoahmpIO%chs2 ) + if ( allocated (NoahmpIO%cqs2) ) deallocate ( NoahmpIO%cqs2 ) + if ( allocated (NoahmpIO%mh_urb2d) ) deallocate ( NoahmpIO%mh_urb2d ) + if ( allocated (NoahmpIO%stdh_urb2d) ) deallocate ( NoahmpIO%stdh_urb2d ) + if ( allocated (NoahmpIO%lf_urb2d) ) deallocate ( NoahmpIO%lf_urb2d ) + if ( allocated (NoahmpIO%trl_urb3d) ) deallocate ( NoahmpIO%trl_urb3d ) + if ( allocated (NoahmpIO%tbl_urb3d) ) deallocate ( NoahmpIO%tbl_urb3d ) + if ( allocated (NoahmpIO%tgl_urb3d) ) deallocate ( NoahmpIO%tgl_urb3d ) + if ( allocated (NoahmpIO%tgrl_urb3d) ) deallocate ( NoahmpIO%tgrl_urb3d ) + if ( allocated (NoahmpIO%smr_urb3d) ) deallocate ( NoahmpIO%smr_urb3d ) + if ( allocated (NoahmpIO%dzr) ) deallocate ( NoahmpIO%dzr ) + if ( allocated (NoahmpIO%dzb) ) deallocate ( NoahmpIO%dzb ) + if ( allocated (NoahmpIO%dzg) ) deallocate ( NoahmpIO%dzg ) + endif + + if(NoahmpIO%sf_urban_physics == 2 .or. NoahmpIO%sf_urban_physics == 3) then ! bep or bem urban models + if ( allocated (NoahmpIO%trb_urb4d) ) deallocate ( NoahmpIO%trb_urb4d ) + if ( allocated (NoahmpIO%tw1_urb4d) ) deallocate ( NoahmpIO%tw1_urb4d ) + if ( allocated (NoahmpIO%tw2_urb4d) ) deallocate ( NoahmpIO%tw2_urb4d ) + if ( allocated (NoahmpIO%tgb_urb4d) ) deallocate ( NoahmpIO%tgb_urb4d ) + if ( allocated (NoahmpIO%sfw1_urb3d) ) deallocate ( NoahmpIO%sfw1_urb3d ) + if ( allocated (NoahmpIO%sfw2_urb3d) ) deallocate ( NoahmpIO%sfw2_urb3d ) + if ( allocated (NoahmpIO%sfr_urb3d) ) deallocate ( NoahmpIO%sfr_urb3d ) + if ( allocated (NoahmpIO%sfg_urb3d) ) deallocate ( NoahmpIO%sfg_urb3d ) + if ( allocated (NoahmpIO%hi_urb2d) ) deallocate ( NoahmpIO%hi_urb2d ) + if ( allocated (NoahmpIO%theta_urban)) deallocate ( NoahmpIO%theta_urban ) + if ( allocated (NoahmpIO%u_urban) ) deallocate ( NoahmpIO%u_urban ) + if ( allocated (NoahmpIO%v_urban) ) deallocate ( NoahmpIO%v_urban ) + if ( allocated (NoahmpIO%dz_urban) ) deallocate ( NoahmpIO%dz_urban ) + if ( allocated (NoahmpIO%rho_urban) ) deallocate ( NoahmpIO%rho_urban ) + if ( allocated (NoahmpIO%p_urban) ) deallocate ( NoahmpIO%p_urban ) + if ( allocated (NoahmpIO%a_u_bep) ) deallocate ( NoahmpIO%a_u_bep ) + if ( allocated (NoahmpIO%a_v_bep) ) deallocate ( NoahmpIO%a_v_bep ) + if ( allocated (NoahmpIO%a_t_bep) ) deallocate ( NoahmpIO%a_t_bep ) + if ( allocated (NoahmpIO%a_q_bep) ) deallocate ( NoahmpIO%a_q_bep ) + if ( allocated (NoahmpIO%a_e_bep) ) deallocate ( NoahmpIO%a_e_bep ) + if ( allocated (NoahmpIO%b_u_bep) ) deallocate ( NoahmpIO%b_u_bep ) + if ( allocated (NoahmpIO%b_v_bep) ) deallocate ( NoahmpIO%b_v_bep ) + if ( allocated (NoahmpIO%b_t_bep) ) deallocate ( NoahmpIO%b_t_bep ) + if ( allocated (NoahmpIO%b_q_bep) ) deallocate ( NoahmpIO%b_q_bep ) + if ( allocated (NoahmpIO%b_e_bep) ) deallocate ( NoahmpIO%b_e_bep ) + if ( allocated (NoahmpIO%dlg_bep) ) deallocate ( NoahmpIO%dlg_bep ) + if ( allocated (NoahmpIO%dl_u_bep) ) deallocate ( NoahmpIO%dl_u_bep ) + if ( allocated (NoahmpIO%sf_bep) ) deallocate ( NoahmpIO%sf_bep ) + if ( allocated (NoahmpIO%vl_bep) ) deallocate ( NoahmpIO%vl_bep ) + endif + + if(NoahmpIO%sf_urban_physics == 3) then ! bem urban model + if ( allocated (NoahmpIO%tlev_urb3d) ) deallocate ( NoahmpIO%tlev_urb3d ) + if ( allocated (NoahmpIO%qlev_urb3d) ) deallocate ( NoahmpIO%qlev_urb3d ) + if ( allocated (NoahmpIO%tw1lev_urb3d) ) deallocate ( NoahmpIO%tw1lev_urb3d ) + if ( allocated (NoahmpIO%tw2lev_urb3d) ) deallocate ( NoahmpIO%tw2lev_urb3d ) + if ( allocated (NoahmpIO%tglev_urb3d) ) deallocate ( NoahmpIO%tglev_urb3d ) + if ( allocated (NoahmpIO%tflev_urb3d) ) deallocate ( NoahmpIO%tflev_urb3d ) + if ( allocated (NoahmpIO%sf_ac_urb3d) ) deallocate ( NoahmpIO%sf_ac_urb3d ) + if ( allocated (NoahmpIO%lf_ac_urb3d) ) deallocate ( NoahmpIO%lf_ac_urb3d ) + if ( allocated (NoahmpIO%cm_ac_urb3d) ) deallocate ( NoahmpIO%cm_ac_urb3d ) + if ( allocated (NoahmpIO%sfvent_urb3d) ) deallocate ( NoahmpIO%sfvent_urb3d ) + if ( allocated (NoahmpIO%lfvent_urb3d) ) deallocate ( NoahmpIO%lfvent_urb3d ) + if ( allocated (NoahmpIO%sfwin1_urb3d) ) deallocate ( NoahmpIO%sfwin1_urb3d ) + if ( allocated (NoahmpIO%sfwin2_urb3d) ) deallocate ( NoahmpIO%sfwin2_urb3d ) + if ( allocated (NoahmpIO%ep_pv_urb3d) ) deallocate ( NoahmpIO%ep_pv_urb3d ) + if ( allocated (NoahmpIO%t_pv_urb3d) ) deallocate ( NoahmpIO%t_pv_urb3d ) + if ( allocated (NoahmpIO%trv_urb4d) ) deallocate ( NoahmpIO%trv_urb4d ) + if ( allocated (NoahmpIO%qr_urb4d) ) deallocate ( NoahmpIO%qr_urb4d ) + if ( allocated (NoahmpIO%qgr_urb3d) ) deallocate ( NoahmpIO%qgr_urb3d ) + if ( allocated (NoahmpIO%tgr_urb3d) ) deallocate ( NoahmpIO%tgr_urb3d ) + if ( allocated (NoahmpIO%drain_urb4d) ) deallocate ( NoahmpIO%drain_urb4d ) + if ( allocated (NoahmpIO%draingr_urb3d)) deallocate ( NoahmpIO%draingr_urb3d ) + if ( allocated (NoahmpIO%sfrv_urb3d) ) deallocate ( NoahmpIO%sfrv_urb3d ) + if ( allocated (NoahmpIO%lfrv_urb3d) ) deallocate ( NoahmpIO%lfrv_urb3d ) + if ( allocated (NoahmpIO%dgr_urb3d) ) deallocate ( NoahmpIO%dgr_urb3d ) + if ( allocated (NoahmpIO%dg_urb3d) ) deallocate ( NoahmpIO%dg_urb3d ) + if ( allocated (NoahmpIO%lfr_urb3d) ) deallocate ( NoahmpIO%lfr_urb3d ) + if ( allocated (NoahmpIO%lfg_urb3d) ) deallocate ( NoahmpIO%lfg_urb3d ) + + endif + +#ifdef WRF_HYDRO + if ( allocated (NoahmpIO%infxsrt) ) deallocate ( NoahmpIO%infxsrt ) + if ( allocated (NoahmpIO%sfcheadrt) ) deallocate ( NoahmpIO%sfcheadrt ) + if ( allocated (NoahmpIO%soldrain) ) deallocate ( NoahmpIO%soldrain ) + if ( allocated (NoahmpIO%qtiledrain)) deallocate ( NoahmpIO%qtiledrain ) + if ( allocated (NoahmpIO%zwatble2d) ) deallocate ( NoahmpIO%zwatble2d ) +#endif + + end associate + + end subroutine NoahmpIOVarFinalizeDefault + +end module NoahmpIOVarFinalizeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarInitMod.F90 new file mode 100644 index 0000000000..ada853d2f1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarInitMod.F90 @@ -0,0 +1,850 @@ +module NoahmpIOVarInitMod + +!!! Initialize Noah-MP input/output variables +!!! Input/Output variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== initialize with default values + + subroutine NoahmpIOVarInitDefault(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------- + associate( & + its => NoahmpIO%its ,& + ite => NoahmpIO%ite ,& + kts => NoahmpIO%kts ,& + kte => NoahmpIO%kte ,& + nsoil => NoahmpIO%nsoil ,& + nsnow => NoahmpIO%nsnow & + ) +! ------------------------------------------------- + + ! Input variables + if ( .not. allocated (NoahmpIO%coszen) ) allocate ( NoahmpIO%coszen (its:ite ) ) ! cosine zenith angle + if ( .not. allocated (NoahmpIO%xlat) ) allocate ( NoahmpIO%xlat (its:ite ) ) ! latitude [radians] + if ( .not. allocated (NoahmpIO%dzs) ) allocate ( NoahmpIO%dzs (1:nsoil ) ) ! thickness of soil layers [m] + if ( .not. allocated (NoahmpIO%zsoil) ) allocate ( NoahmpIO%zsoil (1:nsoil ) ) ! depth to soil interfaces [m] + if ( .not. allocated (NoahmpIO%ivgtyp) ) allocate ( NoahmpIO%ivgtyp (its:ite ) ) ! vegetation type + if ( .not. allocated (NoahmpIO%isltyp) ) allocate ( NoahmpIO%isltyp (its:ite ) ) ! soil type + if ( .not. allocated (NoahmpIO%vegfra) ) allocate ( NoahmpIO%vegfra (its:ite ) ) ! vegetation fraction [] + if ( .not. allocated (NoahmpIO%tmn) ) allocate ( NoahmpIO%tmn (its:ite ) ) ! deep soil temperature [K] + if ( .not. allocated (NoahmpIO%xland) ) allocate ( NoahmpIO%xland (its:ite ) ) ! =2 ocean; =1 land/seaice + if ( .not. allocated (NoahmpIO%xice) ) allocate ( NoahmpIO%xice (its:ite ) ) ! fraction of grid that is seaice + if ( .not. allocated (NoahmpIO%swdown) ) allocate ( NoahmpIO%swdown (its:ite ) ) ! solar down at surface [W m-2] + if ( .not. allocated (NoahmpIO%swddir) ) allocate ( NoahmpIO%swddir (its:ite ) ) ! solar down at surface [W m-2] for new urban solar panel + if ( .not. allocated (NoahmpIO%swddif) ) allocate ( NoahmpIO%swddif (its:ite ) ) ! solar down at surface [W m-2] for new urban solar panel + if ( .not. allocated (NoahmpIO%glw) ) allocate ( NoahmpIO%glw (its:ite ) ) ! longwave down at surface [W m-2] + if ( .not. allocated (NoahmpIO%rainbl) ) allocate ( NoahmpIO%rainbl (its:ite ) ) ! total precipitation entering land model [mm] per time step + if ( .not. allocated (NoahmpIO%snowbl) ) allocate ( NoahmpIO%snowbl (its:ite ) ) ! snow entering land model [mm] per time step + if ( .not. allocated (NoahmpIO%sr) ) allocate ( NoahmpIO%sr (its:ite ) ) ! frozen precip ratio entering land model [-] + if ( .not. allocated (NoahmpIO%raincv) ) allocate ( NoahmpIO%raincv (its:ite ) ) ! convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%rainncv) ) allocate ( NoahmpIO%rainncv (its:ite ) ) ! non-convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%rainshv) ) allocate ( NoahmpIO%rainshv (its:ite ) ) ! shallow conv. precip forcing [mm] + if ( .not. allocated (NoahmpIO%snowncv) ) allocate ( NoahmpIO%snowncv (its:ite ) ) ! non-covective snow forcing (subset of rainncv) [mm] + if ( .not. allocated (NoahmpIO%graupelncv)) allocate ( NoahmpIO%graupelncv (its:ite ) ) ! non-convective graupel forcing (subset of rainncv) [mm] + if ( .not. allocated (NoahmpIO%hailncv) ) allocate ( NoahmpIO%hailncv (its:ite ) ) ! non-convective hail forcing (subset of rainncv) [mm] + if ( .not. allocated (NoahmpIO%mp_rainc) ) allocate ( NoahmpIO%mp_rainc (its:ite ) ) ! convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%mp_rainnc) ) allocate ( NoahmpIO%mp_rainnc (its:ite ) ) ! non-convective precip forcing [mm] + if ( .not. allocated (NoahmpIO%mp_shcv) ) allocate ( NoahmpIO%mp_shcv (its:ite ) ) ! shallow conv. precip forcing [mm] + if ( .not. allocated (NoahmpIO%mp_snow) ) allocate ( NoahmpIO%mp_snow (its:ite ) ) ! non-covective snow (subset of rainnc) [mm] + if ( .not. allocated (NoahmpIO%mp_graup) ) allocate ( NoahmpIO%mp_graup (its:ite ) ) ! non-convective graupel (subset of rainnc) [mm] + if ( .not. allocated (NoahmpIO%mp_hail) ) allocate ( NoahmpIO%mp_hail (its:ite ) ) ! non-convective hail (subset of rainnc) [mm] + if ( .not. allocated (NoahmpIO%seaice) ) allocate ( NoahmpIO%seaice (its:ite ) ) ! seaice fraction + if ( .not. allocated (NoahmpIO%dz8w) ) allocate ( NoahmpIO%dz8w (its:ite,kts:kte ) ) ! thickness of atmo layers [m] + if ( .not. allocated (NoahmpIO%t_phy) ) allocate ( NoahmpIO%t_phy (its:ite,kts:kte ) ) ! 3d atmospheric temperature valid at mid-levels [K] + if ( .not. allocated (NoahmpIO%qv_curr) ) allocate ( NoahmpIO%qv_curr (its:ite,kts:kte ) ) ! 3d water vapor mixing ratio [kg/kg_dry] + if ( .not. allocated (NoahmpIO%u_phy) ) allocate ( NoahmpIO%u_phy (its:ite,kts:kte ) ) ! 3d u wind component [m/s] + if ( .not. allocated (NoahmpIO%v_phy) ) allocate ( NoahmpIO%v_phy (its:ite,kts:kte ) ) ! 3d v wind component [m/s] + if ( .not. allocated (NoahmpIO%p8w) ) allocate ( NoahmpIO%p8w (its:ite,kts:kte ) ) ! 3d pressure, valid at interface [Pa] + + ! spatial varying parameter map + if ( NoahmpIO%iopt_soil > 1 ) then + if ( .not. allocated (NoahmpIO%soilcomp)) allocate ( NoahmpIO%soilcomp (its:ite,1:2*nsoil) ) ! soil sand and clay content [fraction] + if ( .not. allocated (NoahmpIO%soilcl1) ) allocate ( NoahmpIO%soilcl1 (its:ite ) ) ! soil texture class with depth + if ( .not. allocated (NoahmpIO%soilcl2) ) allocate ( NoahmpIO%soilcl2 (its:ite ) ) ! soil texture class with depth + if ( .not. allocated (NoahmpIO%soilcl3) ) allocate ( NoahmpIO%soilcl3 (its:ite ) ) ! soil texture class with depth + if ( .not. allocated (NoahmpIO%soilcl4) ) allocate ( NoahmpIO%soilcl4 (its:ite ) ) ! soil texture class with depth + endif + if ( NoahmpIO%iopt_soil == 4 ) then + if ( .not. allocated (NoahmpIO%bexp_3d) ) allocate ( NoahmpIO%bexp_3d (its:ite,1:nsoil) ) ! c-h b exponent + if ( .not. allocated (NoahmpIO%smcdry_3d) ) allocate ( NoahmpIO%smcdry_3d (its:ite,1:nsoil) ) ! soil moisture limit: dry + if ( .not. allocated (NoahmpIO%smcwlt_3d) ) allocate ( NoahmpIO%smcwlt_3d (its:ite,1:nsoil) ) ! soil moisture limit: wilt + if ( .not. allocated (NoahmpIO%smcref_3d) ) allocate ( NoahmpIO%smcref_3d (its:ite,1:nsoil) ) ! soil moisture limit: reference + if ( .not. allocated (NoahmpIO%smcmax_3d) ) allocate ( NoahmpIO%smcmax_3d (its:ite,1:nsoil) ) ! soil moisture limit: max + if ( .not. allocated (NoahmpIO%dksat_3d) ) allocate ( NoahmpIO%dksat_3d (its:ite,1:nsoil) ) ! saturated soil conductivity + if ( .not. allocated (NoahmpIO%dwsat_3d) ) allocate ( NoahmpIO%dwsat_3d (its:ite,1:nsoil) ) ! saturated soil diffusivity + if ( .not. allocated (NoahmpIO%psisat_3d) ) allocate ( NoahmpIO%psisat_3d (its:ite,1:nsoil) ) ! saturated matric potential + if ( .not. allocated (NoahmpIO%quartz_3d) ) allocate ( NoahmpIO%quartz_3d (its:ite,1:nsoil) ) ! soil quartz content + if ( .not. allocated (NoahmpIO%refdk_2d) ) allocate ( NoahmpIO%refdk_2d (its:ite ) ) ! reference soil conductivity + if ( .not. allocated (NoahmpIO%refkdt_2d) ) allocate ( NoahmpIO%refkdt_2d (its:ite ) ) ! soil infiltration parameter + if ( .not. allocated (NoahmpIO%irr_frac_2d) ) allocate ( NoahmpIO%irr_frac_2d (its:ite ) ) ! irrigation fraction + if ( .not. allocated (NoahmpIO%irr_har_2d) ) allocate ( NoahmpIO%irr_har_2d (its:ite ) ) ! number of days before harvest date to stop irrigation + if ( .not. allocated (NoahmpIO%irr_lai_2d) ) allocate ( NoahmpIO%irr_lai_2d (its:ite ) ) ! minimum lai to trigger irrigation + if ( .not. allocated (NoahmpIO%irr_mad_2d) ) allocate ( NoahmpIO%irr_mad_2d (its:ite ) ) ! management allowable deficit (0-1) + if ( .not. allocated (NoahmpIO%filoss_2d) ) allocate ( NoahmpIO%filoss_2d (its:ite ) ) ! fraction of flood irrigation loss (0-1) + if ( .not. allocated (NoahmpIO%sprir_rate_2d)) allocate ( NoahmpIO%sprir_rate_2d (its:ite ) ) ! mm/h, sprinkler irrigation rate + if ( .not. allocated (NoahmpIO%micir_rate_2d)) allocate ( NoahmpIO%micir_rate_2d (its:ite ) ) ! mm/h, micro irrigation rate + if ( .not. allocated (NoahmpIO%firtfac_2d) ) allocate ( NoahmpIO%firtfac_2d (its:ite ) ) ! flood application rate factor + if ( .not. allocated (NoahmpIO%ir_rain_2d) ) allocate ( NoahmpIO%ir_rain_2d (its:ite ) ) ! maximum precipitation to stop irrigation trigger + if ( .not. allocated (NoahmpIO%bvic_2d) ) allocate ( NoahmpIO%bvic_2d (its:ite ) ) ! VIC model infiltration parameter [-] + if ( .not. allocated (NoahmpIO%axaj_2d) ) allocate ( NoahmpIO%axaj_2d (its:ite ) ) ! tension water distribution inflection parameter [-] + if ( .not. allocated (NoahmpIO%bxaj_2d) ) allocate ( NoahmpIO%bxaj_2d (its:ite ) ) ! tension water distribution shape parameter [-] + if ( .not. allocated (NoahmpIO%xxaj_2d) ) allocate ( NoahmpIO%xxaj_2d (its:ite ) ) ! free water distribution shape parameter [-] + if ( .not. allocated (NoahmpIO%bdvic_2d) ) allocate ( NoahmpIO%bdvic_2d (its:ite ) ) ! DVIC model infiltration parameter [-] + if ( .not. allocated (NoahmpIO%gdvic_2d) ) allocate ( NoahmpIO%gdvic_2d (its:ite ) ) ! mean capillary drive (m) for infiltration models + if ( .not. allocated (NoahmpIO%bbvic_2d) ) allocate ( NoahmpIO%bbvic_2d (its:ite ) ) ! dvic heterogeniety parameter for infiltration [-] + if ( .not. allocated (NoahmpIO%klat_fac) ) allocate ( NoahmpIO%klat_fac (its:ite ) ) ! factor multiplier to hydraulic conductivity + if ( .not. allocated (NoahmpIO%tdsmc_fac) ) allocate ( NoahmpIO%tdsmc_fac (its:ite ) ) ! factor multiplier to field capacity + if ( .not. allocated (NoahmpIO%td_dc) ) allocate ( NoahmpIO%td_dc (its:ite ) ) ! drainage coefficient for simple + if ( .not. allocated (NoahmpIO%td_dcoef) ) allocate ( NoahmpIO%td_dcoef (its:ite ) ) ! drainage coefficient for Hooghoudt + if ( .not. allocated (NoahmpIO%td_ddrain) ) allocate ( NoahmpIO%td_ddrain (its:ite ) ) ! depth of drain + if ( .not. allocated (NoahmpIO%td_radi) ) allocate ( NoahmpIO%td_radi (its:ite ) ) ! tile radius + if ( .not. allocated (NoahmpIO%td_spac) ) allocate ( NoahmpIO%td_spac (its:ite ) ) ! tile spacing + endif + + ! INOUT (with generic LSM equivalent) (as defined in WRF) + if ( .not. allocated (NoahmpIO%tsk) ) allocate ( NoahmpIO%tsk (its:ite ) ) ! surface radiative temperature [K] + if ( .not. allocated (NoahmpIO%hfx) ) allocate ( NoahmpIO%hfx (its:ite ) ) ! sensible heat flux [W m-2] + if ( .not. allocated (NoahmpIO%qfx) ) allocate ( NoahmpIO%qfx (its:ite ) ) ! latent heat flux [kg s-1 m-2] + if ( .not. allocated (NoahmpIO%lh) ) allocate ( NoahmpIO%lh (its:ite ) ) ! latent heat flux [W m-2] + if ( .not. allocated (NoahmpIO%grdflx) ) allocate ( NoahmpIO%grdflx (its:ite ) ) ! ground/snow heat flux [W m-2] + if ( .not. allocated (NoahmpIO%smstav) ) allocate ( NoahmpIO%smstav (its:ite ) ) ! soil moisture avail. [not used] + if ( .not. allocated (NoahmpIO%smstot) ) allocate ( NoahmpIO%smstot (its:ite ) ) ! total soil water [mm][not used] + if ( .not. allocated (NoahmpIO%sfcrunoff)) allocate ( NoahmpIO%sfcrunoff (its:ite ) ) ! accumulated surface runoff [m] + if ( .not. allocated (NoahmpIO%udrunoff) ) allocate ( NoahmpIO%udrunoff (its:ite ) ) ! accumulated sub-surface runoff [m] + if ( .not. allocated (NoahmpIO%albedo) ) allocate ( NoahmpIO%albedo (its:ite ) ) ! total grid albedo [] + if ( .not. allocated (NoahmpIO%snowc) ) allocate ( NoahmpIO%snowc (its:ite ) ) ! snow cover fraction [] + if ( .not. allocated (NoahmpIO%snow) ) allocate ( NoahmpIO%snow (its:ite ) ) ! snow water equivalent [mm] + if ( .not. allocated (NoahmpIO%snowh) ) allocate ( NoahmpIO%snowh (its:ite ) ) ! physical snow depth [m] + if ( .not. allocated (NoahmpIO%canwat) ) allocate ( NoahmpIO%canwat (its:ite ) ) ! total canopy water + ice [mm] + if ( .not. allocated (NoahmpIO%acsnom) ) allocate ( NoahmpIO%acsnom (its:ite ) ) ! accumulated snow melt leaving pack + if ( .not. allocated (NoahmpIO%acsnow) ) allocate ( NoahmpIO%acsnow (its:ite ) ) ! accumulated snow on grid + if ( .not. allocated (NoahmpIO%emiss) ) allocate ( NoahmpIO%emiss (its:ite ) ) ! surface bulk emissivity + if ( .not. allocated (NoahmpIO%qsfc) ) allocate ( NoahmpIO%qsfc (its:ite ) ) ! bulk surface specific humidity + if ( .not. allocated (NoahmpIO%smoiseq) ) allocate ( NoahmpIO%smoiseq (its:ite,1:nsoil) ) ! equilibrium volumetric soil moisture [m3/m3] + if ( .not. allocated (NoahmpIO%smois) ) allocate ( NoahmpIO%smois (its:ite,1:nsoil) ) ! volumetric soil moisture [m3/m3] + if ( .not. allocated (NoahmpIO%sh2o) ) allocate ( NoahmpIO%sh2o (its:ite,1:nsoil) ) ! volumetric liquid soil moisture [m3/m3] + if ( .not. allocated (NoahmpIO%tslb) ) allocate ( NoahmpIO%tslb (its:ite,1:nsoil) ) ! soil temperature [K] + + ! INOUT (with no Noah LSM equivalent) (as defined in WRF) + if ( .not. allocated (NoahmpIO%isnowxy) ) allocate ( NoahmpIO%isnowxy (its:ite ) ) ! actual no. of snow layers + if ( .not. allocated (NoahmpIO%tvxy) ) allocate ( NoahmpIO%tvxy (its:ite ) ) ! vegetation leaf temperature + if ( .not. allocated (NoahmpIO%tgxy) ) allocate ( NoahmpIO%tgxy (its:ite ) ) ! bulk ground surface temperature + if ( .not. allocated (NoahmpIO%canicexy) ) allocate ( NoahmpIO%canicexy (its:ite ) ) ! canopy-intercepted ice (mm) + if ( .not. allocated (NoahmpIO%canliqxy) ) allocate ( NoahmpIO%canliqxy (its:ite ) ) ! canopy-intercepted liquid water (mm) + if ( .not. allocated (NoahmpIO%eahxy) ) allocate ( NoahmpIO%eahxy (its:ite ) ) ! canopy air vapor pressure (Pa) + if ( .not. allocated (NoahmpIO%tahxy) ) allocate ( NoahmpIO%tahxy (its:ite ) ) ! canopy air temperature (K) + if ( .not. allocated (NoahmpIO%cmxy) ) allocate ( NoahmpIO%cmxy (its:ite ) ) ! bulk momentum drag coefficient + if ( .not. allocated (NoahmpIO%chxy) ) allocate ( NoahmpIO%chxy (its:ite ) ) ! bulk sensible heat exchange coefficient + if ( .not. allocated (NoahmpIO%fwetxy) ) allocate ( NoahmpIO%fwetxy (its:ite ) ) ! wetted or snowed fraction of the canopy (-) + if ( .not. allocated (NoahmpIO%sneqvoxy) ) allocate ( NoahmpIO%sneqvoxy (its:ite ) ) ! snow mass at last time step(mm H2O) + if ( .not. allocated (NoahmpIO%alboldxy) ) allocate ( NoahmpIO%alboldxy (its:ite ) ) ! snow albedo at last time step (-) + if ( .not. allocated (NoahmpIO%qsnowxy) ) allocate ( NoahmpIO%qsnowxy (its:ite ) ) ! snowfall on the ground [mm/s] + if ( .not. allocated (NoahmpIO%qrainxy) ) allocate ( NoahmpIO%qrainxy (its:ite ) ) ! rainfall on the ground [mm/s] + if ( .not. allocated (NoahmpIO%wslakexy) ) allocate ( NoahmpIO%wslakexy (its:ite ) ) ! lake water storage [mm] + if ( .not. allocated (NoahmpIO%zwtxy) ) allocate ( NoahmpIO%zwtxy (its:ite ) ) ! water table depth [m] + if ( .not. allocated (NoahmpIO%waxy) ) allocate ( NoahmpIO%waxy (its:ite ) ) ! water in the "aquifer" [mm] + if ( .not. allocated (NoahmpIO%wtxy) ) allocate ( NoahmpIO%wtxy (its:ite ) ) ! groundwater storage [mm] + if ( .not. allocated (NoahmpIO%smcwtdxy) ) allocate ( NoahmpIO%smcwtdxy (its:ite ) ) ! soil moisture below the bottom of the column (m3 m-3) + if ( .not. allocated (NoahmpIO%deeprechxy)) allocate ( NoahmpIO%deeprechxy (its:ite ) ) ! recharge to the water table when deep (m) + if ( .not. allocated (NoahmpIO%rechxy) ) allocate ( NoahmpIO%rechxy (its:ite ) ) ! recharge to the water table (diagnostic) (m) + if ( .not. allocated (NoahmpIO%lfmassxy) ) allocate ( NoahmpIO%lfmassxy (its:ite ) ) ! leaf mass [g/m2] + if ( .not. allocated (NoahmpIO%rtmassxy) ) allocate ( NoahmpIO%rtmassxy (its:ite ) ) ! mass of fine roots [g/m2] + if ( .not. allocated (NoahmpIO%stmassxy) ) allocate ( NoahmpIO%stmassxy (its:ite ) ) ! stem mass [g/m2] + if ( .not. allocated (NoahmpIO%woodxy) ) allocate ( NoahmpIO%woodxy (its:ite ) ) ! mass of wood (incl. woody roots) [g/m2] + if ( .not. allocated (NoahmpIO%grainxy) ) allocate ( NoahmpIO%grainxy (its:ite ) ) ! mass of grain xing [g/m2] + if ( .not. allocated (NoahmpIO%gddxy) ) allocate ( NoahmpIO%gddxy (its:ite ) ) ! growing degree days xing four + if ( .not. allocated (NoahmpIO%stblcpxy) ) allocate ( NoahmpIO%stblcpxy (its:ite ) ) ! stable carbon in deep soil [g/m2] + if ( .not. allocated (NoahmpIO%fastcpxy) ) allocate ( NoahmpIO%fastcpxy (its:ite ) ) ! short-lived carbon, shallow soil [g/m2] + if ( .not. allocated (NoahmpIO%lai) ) allocate ( NoahmpIO%lai (its:ite ) ) ! leaf area index + if ( .not. allocated (NoahmpIO%xsaixy) ) allocate ( NoahmpIO%xsaixy (its:ite ) ) ! stem area index + if ( .not. allocated (NoahmpIO%taussxy) ) allocate ( NoahmpIO%taussxy (its:ite ) ) ! snow age factor + if ( .not. allocated (NoahmpIO%tsnoxy) ) allocate ( NoahmpIO%tsnoxy (its:ite,-nsnow+1:0 ) ) ! snow temperature [K] + if ( .not. allocated (NoahmpIO%zsnsoxy) ) allocate ( NoahmpIO%zsnsoxy (its:ite,-nsnow+1:nsoil) ) ! snow layer depth [m] + if ( .not. allocated (NoahmpIO%snicexy) ) allocate ( NoahmpIO%snicexy (its:ite,-nsnow+1:0 ) ) ! snow layer ice [mm] + if ( .not. allocated (NoahmpIO%snliqxy) ) allocate ( NoahmpIO%snliqxy (its:ite,-nsnow+1:0 ) ) ! snow layer liquid water [mm] + + ! irrigation + if ( .not. allocated (NoahmpIO%irfract) ) allocate ( NoahmpIO%irfract (its:ite) ) ! irrigation fraction + if ( .not. allocated (NoahmpIO%sifract) ) allocate ( NoahmpIO%sifract (its:ite) ) ! sprinkler irrigation fraction + if ( .not. allocated (NoahmpIO%mifract) ) allocate ( NoahmpIO%mifract (its:ite) ) ! micro irrigation fraction + if ( .not. allocated (NoahmpIO%fifract) ) allocate ( NoahmpIO%fifract (its:ite) ) ! flood irrigation fraction + if ( .not. allocated (NoahmpIO%irnumsi) ) allocate ( NoahmpIO%irnumsi (its:ite) ) ! irrigation event number, sprinkler + if ( .not. allocated (NoahmpIO%irnummi) ) allocate ( NoahmpIO%irnummi (its:ite) ) ! irrigation event number, micro + if ( .not. allocated (NoahmpIO%irnumfi) ) allocate ( NoahmpIO%irnumfi (its:ite) ) ! irrigation event number, flood + if ( .not. allocated (NoahmpIO%irwatsi) ) allocate ( NoahmpIO%irwatsi (its:ite) ) ! irrigation water amount [m] to be applied, sprinkler + if ( .not. allocated (NoahmpIO%irwatmi) ) allocate ( NoahmpIO%irwatmi (its:ite) ) ! irrigation water amount [m] to be applied, micro + if ( .not. allocated (NoahmpIO%irwatfi) ) allocate ( NoahmpIO%irwatfi (its:ite) ) ! irrigation water amount [m] to be applied, flood + if ( .not. allocated (NoahmpIO%ireloss) ) allocate ( NoahmpIO%ireloss (its:ite) ) ! loss of irrigation water to evaporation,sprinkler [mm] + if ( .not. allocated (NoahmpIO%irsivol) ) allocate ( NoahmpIO%irsivol (its:ite) ) ! amount of irrigation by sprinkler (mm) + if ( .not. allocated (NoahmpIO%irmivol) ) allocate ( NoahmpIO%irmivol (its:ite) ) ! amount of irrigation by micro (mm) + if ( .not. allocated (NoahmpIO%irfivol) ) allocate ( NoahmpIO%irfivol (its:ite) ) ! amount of irrigation by micro (mm) + if ( .not. allocated (NoahmpIO%irrsplh) ) allocate ( NoahmpIO%irrsplh (its:ite) ) ! latent heating from sprinkler evaporation (W/m2) + if ( .not. allocated (NoahmpIO%loctim) ) allocate ( NoahmpIO%loctim (its:ite) ) ! local time + + ! OUT (with no Noah LSM equivalent) (as defined in WRF) + if ( .not. allocated (NoahmpIO%t2mvxy) ) allocate ( NoahmpIO%t2mvxy (its:ite) ) ! 2m temperature of vegetation part + if ( .not. allocated (NoahmpIO%t2mbxy) ) allocate ( NoahmpIO%t2mbxy (its:ite) ) ! 2m temperature of bare ground part + if ( .not. allocated (NoahmpIO%q2mvxy) ) allocate ( NoahmpIO%q2mvxy (its:ite) ) ! 2m mixing ratio of vegetation part + if ( .not. allocated (NoahmpIO%q2mbxy) ) allocate ( NoahmpIO%q2mbxy (its:ite) ) ! 2m mixing ratio of bare ground part + if ( .not. allocated (NoahmpIO%tradxy) ) allocate ( NoahmpIO%tradxy (its:ite) ) ! surface radiative temperature (K) + if ( .not. allocated (NoahmpIO%neexy) ) allocate ( NoahmpIO%neexy (its:ite) ) ! net ecosys exchange (g/m2/s CO2) + if ( .not. allocated (NoahmpIO%gppxy) ) allocate ( NoahmpIO%gppxy (its:ite) ) ! gross primary assimilation [g/m2/s C] + if ( .not. allocated (NoahmpIO%nppxy) ) allocate ( NoahmpIO%nppxy (its:ite) ) ! net primary productivity [g/m2/s C] + if ( .not. allocated (NoahmpIO%fvegxy) ) allocate ( NoahmpIO%fvegxy (its:ite) ) ! noah-mp vegetation fraction [-] + if ( .not. allocated (NoahmpIO%runsfxy) ) allocate ( NoahmpIO%runsfxy (its:ite) ) ! surface runoff [mm per soil timestep] + if ( .not. allocated (NoahmpIO%runsbxy) ) allocate ( NoahmpIO%runsbxy (its:ite) ) ! subsurface runoff [mm per soil timestep] + if ( .not. allocated (NoahmpIO%ecanxy) ) allocate ( NoahmpIO%ecanxy (its:ite) ) ! evaporation of intercepted water (mm/s) + if ( .not. allocated (NoahmpIO%edirxy) ) allocate ( NoahmpIO%edirxy (its:ite) ) ! soil surface evaporation rate (mm/s] + if ( .not. allocated (NoahmpIO%etranxy) ) allocate ( NoahmpIO%etranxy (its:ite) ) ! transpiration rate (mm/s) + if ( .not. allocated (NoahmpIO%fsaxy) ) allocate ( NoahmpIO%fsaxy (its:ite) ) ! total absorbed solar radiation (W/m2) + if ( .not. allocated (NoahmpIO%firaxy) ) allocate ( NoahmpIO%firaxy (its:ite) ) ! total net longwave rad (W/m2) [+ to atm] + if ( .not. allocated (NoahmpIO%aparxy) ) allocate ( NoahmpIO%aparxy (its:ite) ) ! photosyn active energy by canopy (W/m2) + if ( .not. allocated (NoahmpIO%psnxy) ) allocate ( NoahmpIO%psnxy (its:ite) ) ! total photosynthesis (umol CO2/m2/s) [+] + if ( .not. allocated (NoahmpIO%savxy) ) allocate ( NoahmpIO%savxy (its:ite) ) ! solar rad absorbed by veg. (W/m2) + if ( .not. allocated (NoahmpIO%sagxy) ) allocate ( NoahmpIO%sagxy (its:ite) ) ! solar rad absorbed by ground (W/m2) + if ( .not. allocated (NoahmpIO%rssunxy) ) allocate ( NoahmpIO%rssunxy (its:ite) ) ! sunlit leaf stomatal resistance (s/m) + if ( .not. allocated (NoahmpIO%rsshaxy) ) allocate ( NoahmpIO%rsshaxy (its:ite) ) ! shaded leaf stomatal resistance (s/m) + if ( .not. allocated (NoahmpIO%bgapxy) ) allocate ( NoahmpIO%bgapxy (its:ite) ) ! between gap fraction + if ( .not. allocated (NoahmpIO%wgapxy) ) allocate ( NoahmpIO%wgapxy (its:ite) ) ! within gap fraction + if ( .not. allocated (NoahmpIO%tgvxy) ) allocate ( NoahmpIO%tgvxy (its:ite) ) ! under canopy ground temperature[K] + if ( .not. allocated (NoahmpIO%tgbxy) ) allocate ( NoahmpIO%tgbxy (its:ite) ) ! bare ground temperature [K] + if ( .not. allocated (NoahmpIO%chvxy) ) allocate ( NoahmpIO%chvxy (its:ite) ) ! sensible heat exchange coefficient vegetated + if ( .not. allocated (NoahmpIO%chbxy) ) allocate ( NoahmpIO%chbxy (its:ite) ) ! sensible heat exchange coefficient bare-ground + if ( .not. allocated (NoahmpIO%shgxy) ) allocate ( NoahmpIO%shgxy (its:ite) ) ! veg ground sen. heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%shcxy) ) allocate ( NoahmpIO%shcxy (its:ite) ) ! canopy sen. heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%shbxy) ) allocate ( NoahmpIO%shbxy (its:ite) ) ! bare sensible heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%evgxy) ) allocate ( NoahmpIO%evgxy (its:ite) ) ! veg ground evap. heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%evbxy) ) allocate ( NoahmpIO%evbxy (its:ite) ) ! bare soil evaporation [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%ghvxy) ) allocate ( NoahmpIO%ghvxy (its:ite) ) ! veg ground heat flux [W/m2] [+ to soil] + if ( .not. allocated (NoahmpIO%ghbxy) ) allocate ( NoahmpIO%ghbxy (its:ite) ) ! bare ground heat flux [W/m2] [+ to soil] + if ( .not. allocated (NoahmpIO%irgxy) ) allocate ( NoahmpIO%irgxy (its:ite) ) ! veg ground net lw rad. [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%ircxy) ) allocate ( NoahmpIO%ircxy (its:ite) ) ! canopy net lw rad. [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%irbxy) ) allocate ( NoahmpIO%irbxy (its:ite) ) ! bare net longwave rad. [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%trxy) ) allocate ( NoahmpIO%trxy (its:ite) ) ! transpiration [w/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%evcxy) ) allocate ( NoahmpIO%evcxy (its:ite) ) ! canopy evaporation heat [W/m2] [+ to atm] + if ( .not. allocated (NoahmpIO%chleafxy) ) allocate ( NoahmpIO%chleafxy (its:ite) ) ! leaf exchange coefficient + if ( .not. allocated (NoahmpIO%chucxy) ) allocate ( NoahmpIO%chucxy (its:ite) ) ! under canopy exchange coefficient + if ( .not. allocated (NoahmpIO%chv2xy) ) allocate ( NoahmpIO%chv2xy (its:ite) ) ! veg 2m exchange coefficient + if ( .not. allocated (NoahmpIO%chb2xy) ) allocate ( NoahmpIO%chb2xy (its:ite) ) ! bare 2m exchange coefficient + if ( .not. allocated (NoahmpIO%rs) ) allocate ( NoahmpIO%rs (its:ite) ) ! total stomatal resistance (s/m) + if ( .not. allocated (NoahmpIO%z0) ) allocate ( NoahmpIO%z0 (its:ite) ) ! roughness length output to WRF + if ( .not. allocated (NoahmpIO%znt) ) allocate ( NoahmpIO%znt (its:ite) ) ! roughness length output to WRF + if ( .not. allocated (NoahmpIO%qtdrain) ) allocate ( NoahmpIO%qtdrain (its:ite) ) ! tile drainage (mm) + if ( .not. allocated (NoahmpIO%td_fraction)) allocate ( NoahmpIO%td_fraction (its:ite) ) ! tile drainage fraction + if ( .not. allocated (NoahmpIO%xlong) ) allocate ( NoahmpIO%xlong (its:ite) ) ! longitude + if ( .not. allocated (NoahmpIO%terrain) ) allocate ( NoahmpIO%terrain (its:ite) ) ! terrain height + if ( .not. allocated (NoahmpIO%gvfmin) ) allocate ( NoahmpIO%gvfmin (its:ite) ) ! annual minimum in vegetation fraction + if ( .not. allocated (NoahmpIO%gvfmax) ) allocate ( NoahmpIO%gvfmax (its:ite) ) ! annual maximum in vegetation fraction + + ! additional output variables + if ( .not. allocated (NoahmpIO%pahxy) ) allocate ( NoahmpIO%pahxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pahgxy) ) allocate ( NoahmpIO%pahgxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pahbxy) ) allocate ( NoahmpIO%pahbxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pahvxy) ) allocate ( NoahmpIO%pahvxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qintsxy) ) allocate ( NoahmpIO%qintsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qintrxy) ) allocate ( NoahmpIO%qintrxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qdripsxy) ) allocate ( NoahmpIO%qdripsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qdriprxy) ) allocate ( NoahmpIO%qdriprxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qthrosxy) ) allocate ( NoahmpIO%qthrosxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qthrorxy) ) allocate ( NoahmpIO%qthrorxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsnsubxy) ) allocate ( NoahmpIO%qsnsubxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsnfroxy) ) allocate ( NoahmpIO%qsnfroxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsubcxy) ) allocate ( NoahmpIO%qsubcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qfrocxy) ) allocate ( NoahmpIO%qfrocxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qevacxy) ) allocate ( NoahmpIO%qevacxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qdewcxy) ) allocate ( NoahmpIO%qdewcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qfrzcxy) ) allocate ( NoahmpIO%qfrzcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qmeltcxy) ) allocate ( NoahmpIO%qmeltcxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qsnbotxy) ) allocate ( NoahmpIO%qsnbotxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qmeltxy) ) allocate ( NoahmpIO%qmeltxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pondingxy) ) allocate ( NoahmpIO%pondingxy (its:ite) ) + if ( .not. allocated (NoahmpIO%fpicexy) ) allocate ( NoahmpIO%fpicexy (its:ite) ) + if ( .not. allocated (NoahmpIO%rainlsm) ) allocate ( NoahmpIO%rainlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%snowlsm) ) allocate ( NoahmpIO%snowlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forctlsm) ) allocate ( NoahmpIO%forctlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forcqlsm) ) allocate ( NoahmpIO%forcqlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forcplsm) ) allocate ( NoahmpIO%forcplsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forczlsm) ) allocate ( NoahmpIO%forczlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%forcwlsm) ) allocate ( NoahmpIO%forcwlsm (its:ite) ) + if ( .not. allocated (NoahmpIO%eflxbxy) ) allocate ( NoahmpIO%eflxbxy (its:ite) ) + if ( .not. allocated (NoahmpIO%soilenergy) ) allocate ( NoahmpIO%soilenergy (its:ite) ) + if ( .not. allocated (NoahmpIO%snowenergy) ) allocate ( NoahmpIO%snowenergy (its:ite) ) + if ( .not. allocated (NoahmpIO%canhsxy) ) allocate ( NoahmpIO%canhsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_dwaterxy)) allocate ( NoahmpIO%acc_dwaterxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_prcpxy) ) allocate ( NoahmpIO%acc_prcpxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_ecanxy) ) allocate ( NoahmpIO%acc_ecanxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_etranxy) ) allocate ( NoahmpIO%acc_etranxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_edirxy) ) allocate ( NoahmpIO%acc_edirxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_ssoilxy) ) allocate ( NoahmpIO%acc_ssoilxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_qinsurxy)) allocate ( NoahmpIO%acc_qinsurxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_qsevaxy) ) allocate ( NoahmpIO%acc_qsevaxy (its:ite) ) + if ( .not. allocated (NoahmpIO%acc_etranixy)) allocate ( NoahmpIO%acc_etranixy (its:ite,1:nsoil) ) + + ! needed for mmf_runoff (iopt_run = 5); not part of mp driver in WRF + if ( .not. allocated (NoahmpIO%msftx) ) allocate ( NoahmpIO%msftx (its:ite) ) + if ( .not. allocated (NoahmpIO%msfty) ) allocate ( NoahmpIO%msfty (its:ite) ) + if ( .not. allocated (NoahmpIO%eqzwt) ) allocate ( NoahmpIO%eqzwt (its:ite) ) + if ( .not. allocated (NoahmpIO%riverbedxy) ) allocate ( NoahmpIO%riverbedxy (its:ite) ) + if ( .not. allocated (NoahmpIO%rivercondxy)) allocate ( NoahmpIO%rivercondxy (its:ite) ) + if ( .not. allocated (NoahmpIO%pexpxy) ) allocate ( NoahmpIO%pexpxy (its:ite) ) + if ( .not. allocated (NoahmpIO%fdepthxy) ) allocate ( NoahmpIO%fdepthxy (its:ite) ) + if ( .not. allocated (NoahmpIO%areaxy) ) allocate ( NoahmpIO%areaxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qrfsxy) ) allocate ( NoahmpIO%qrfsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qspringsxy) ) allocate ( NoahmpIO%qspringsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qrfxy) ) allocate ( NoahmpIO%qrfxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qspringxy) ) allocate ( NoahmpIO%qspringxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qslatxy) ) allocate ( NoahmpIO%qslatxy (its:ite) ) + if ( .not. allocated (NoahmpIO%qlatxy) ) allocate ( NoahmpIO%qlatxy (its:ite) ) + if ( .not. allocated (NoahmpIO%rechclim) ) allocate ( NoahmpIO%rechclim (its:ite) ) + if ( .not. allocated (NoahmpIO%rivermask) ) allocate ( NoahmpIO%rivermask (its:ite) ) + if ( .not. allocated (NoahmpIO%nonriverxy) ) allocate ( NoahmpIO%nonriverxy (its:ite) ) + + ! needed for crop model (opt_crop=1) + if ( .not. allocated (NoahmpIO%pgsxy) ) allocate ( NoahmpIO%pgsxy (its:ite) ) + if ( .not. allocated (NoahmpIO%cropcat) ) allocate ( NoahmpIO%cropcat (its:ite) ) + if ( .not. allocated (NoahmpIO%planting) ) allocate ( NoahmpIO%planting (its:ite) ) + if ( .not. allocated (NoahmpIO%harvest) ) allocate ( NoahmpIO%harvest (its:ite) ) + if ( .not. allocated (NoahmpIO%season_gdd)) allocate ( NoahmpIO%season_gdd (its:ite) ) + if ( .not. allocated (NoahmpIO%croptype) ) allocate ( NoahmpIO%croptype (its:ite,5) ) + + ! Single- and Multi-layer Urban Models + if ( NoahmpIO%sf_urban_physics > 0 ) then + if ( .not. allocated (NoahmpIO%sh_urb2d) ) allocate ( NoahmpIO%sh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lh_urb2d) ) allocate ( NoahmpIO%lh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%g_urb2d) ) allocate ( NoahmpIO%g_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%rn_urb2d) ) allocate ( NoahmpIO%rn_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%ts_urb2d) ) allocate ( NoahmpIO%ts_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%hrang) ) allocate ( NoahmpIO%hrang (its:ite) ) + if ( .not. allocated (NoahmpIO%frc_urb2d) ) allocate ( NoahmpIO%frc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%utype_urb2d)) allocate ( NoahmpIO%utype_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lp_urb2d) ) allocate ( NoahmpIO%lp_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lb_urb2d) ) allocate ( NoahmpIO%lb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%hgt_urb2d) ) allocate ( NoahmpIO%hgt_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%ust) ) allocate ( NoahmpIO%ust (its:ite) ) + !endif + + !if(NoahmpIO%sf_urban_physics == 1 ) then ! single layer urban model + if ( .not. allocated (NoahmpIO%cmr_sfcdif) ) allocate ( NoahmpIO%cmr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%chr_sfcdif) ) allocate ( NoahmpIO%chr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%cmc_sfcdif) ) allocate ( NoahmpIO%cmc_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%chc_sfcdif) ) allocate ( NoahmpIO%chc_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%cmgr_sfcdif) ) allocate ( NoahmpIO%cmgr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%chgr_sfcdif) ) allocate ( NoahmpIO%chgr_sfcdif (its:ite) ) + if ( .not. allocated (NoahmpIO%tr_urb2d) ) allocate ( NoahmpIO%tr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tb_urb2d) ) allocate ( NoahmpIO%tb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tg_urb2d) ) allocate ( NoahmpIO%tg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tc_urb2d) ) allocate ( NoahmpIO%tc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%qc_urb2d) ) allocate ( NoahmpIO%qc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%uc_urb2d) ) allocate ( NoahmpIO%uc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxr_urb2d) ) allocate ( NoahmpIO%xxxr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxb_urb2d) ) allocate ( NoahmpIO%xxxb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxg_urb2d) ) allocate ( NoahmpIO%xxxg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%xxxc_urb2d) ) allocate ( NoahmpIO%xxxc_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%psim_urb2d) ) allocate ( NoahmpIO%psim_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%psih_urb2d) ) allocate ( NoahmpIO%psih_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%u10_urb2d) ) allocate ( NoahmpIO%u10_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%v10_urb2d) ) allocate ( NoahmpIO%v10_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%gz1oz0_urb2d) ) allocate ( NoahmpIO%gz1oz0_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%akms_urb2d) ) allocate ( NoahmpIO%akms_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%th2_urb2d) ) allocate ( NoahmpIO%th2_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%q2_urb2d) ) allocate ( NoahmpIO%q2_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%ust_urb2d) ) allocate ( NoahmpIO%ust_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%cmcr_urb2d) ) allocate ( NoahmpIO%cmcr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%tgr_urb2d) ) allocate ( NoahmpIO%tgr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%drelr_urb2d) ) allocate ( NoahmpIO%drelr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%drelb_urb2d) ) allocate ( NoahmpIO%drelb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%drelg_urb2d) ) allocate ( NoahmpIO%drelg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%flxhumr_urb2d)) allocate ( NoahmpIO%flxhumr_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%flxhumb_urb2d)) allocate ( NoahmpIO%flxhumb_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%flxhumg_urb2d)) allocate ( NoahmpIO%flxhumg_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%chs) ) allocate ( NoahmpIO%chs (its:ite) ) + if ( .not. allocated (NoahmpIO%chs2) ) allocate ( NoahmpIO%chs2 (its:ite) ) + if ( .not. allocated (NoahmpIO%cqs2) ) allocate ( NoahmpIO%cqs2 (its:ite) ) + if ( .not. allocated (NoahmpIO%mh_urb2d) ) allocate ( NoahmpIO%mh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%stdh_urb2d) ) allocate ( NoahmpIO%stdh_urb2d (its:ite) ) + if ( .not. allocated (NoahmpIO%lf_urb2d) ) allocate ( NoahmpIO%lf_urb2d (its:ite,4) ) + if ( .not. allocated (NoahmpIO%trl_urb3d) ) allocate ( NoahmpIO%trl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%tbl_urb3d) ) allocate ( NoahmpIO%tbl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%tgl_urb3d) ) allocate ( NoahmpIO%tgl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%tgrl_urb3d) ) allocate ( NoahmpIO%tgrl_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%smr_urb3d) ) allocate ( NoahmpIO%smr_urb3d (its:ite,1:nsoil) ) + if ( .not. allocated (NoahmpIO%dzr) ) allocate ( NoahmpIO%dzr ( 1:nsoil) ) + if ( .not. allocated (NoahmpIO%dzb) ) allocate ( NoahmpIO%dzb ( 1:nsoil) ) + if ( .not. allocated (NoahmpIO%dzg) ) allocate ( NoahmpIO%dzg ( 1:nsoil) ) + !endif + + !if(sf_urban_physics == 2 .or. sf_urban_physics == 3) then ! bep or bem urban models + if ( .not. allocated (NoahmpIO%trb_urb4d) ) allocate ( NoahmpIO%trb_urb4d (its:ite,NoahmpIO%urban_map_zrd) ) + if ( .not. allocated (NoahmpIO%tw1_urb4d) ) allocate ( NoahmpIO%tw1_urb4d (its:ite,NoahmpIO%urban_map_zwd) ) + if ( .not. allocated (NoahmpIO%tw2_urb4d) ) allocate ( NoahmpIO%tw2_urb4d (its:ite,NoahmpIO%urban_map_zwd) ) + if ( .not. allocated (NoahmpIO%tgb_urb4d) ) allocate ( NoahmpIO%tgb_urb4d (its:ite,NoahmpIO%urban_map_gd ) ) + if ( .not. allocated (NoahmpIO%sfw1_urb3d) ) allocate ( NoahmpIO%sfw1_urb3d (its:ite,NoahmpIO%urban_map_zd ) ) + if ( .not. allocated (NoahmpIO%sfw2_urb3d) ) allocate ( NoahmpIO%sfw2_urb3d (its:ite,NoahmpIO%urban_map_zd ) ) + if ( .not. allocated (NoahmpIO%sfr_urb3d) ) allocate ( NoahmpIO%sfr_urb3d (its:ite,NoahmpIO%urban_map_zdf) ) + if ( .not. allocated (NoahmpIO%sfg_urb3d) ) allocate ( NoahmpIO%sfg_urb3d (its:ite,NoahmpIO%num_urban_ndm) ) + if ( .not. allocated (NoahmpIO%hi_urb2d) ) allocate ( NoahmpIO%hi_urb2d (its:ite,NoahmpIO%num_urban_hi ) ) + if ( .not. allocated (NoahmpIO%theta_urban)) allocate ( NoahmpIO%theta_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%u_urban) ) allocate ( NoahmpIO%u_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%v_urban) ) allocate ( NoahmpIO%v_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%dz_urban) ) allocate ( NoahmpIO%dz_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%rho_urban) ) allocate ( NoahmpIO%rho_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%p_urban) ) allocate ( NoahmpIO%p_urban (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_u_bep) ) allocate ( NoahmpIO%a_u_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_v_bep) ) allocate ( NoahmpIO%a_v_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_t_bep) ) allocate ( NoahmpIO%a_t_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_q_bep) ) allocate ( NoahmpIO%a_q_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%a_e_bep) ) allocate ( NoahmpIO%a_e_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_u_bep) ) allocate ( NoahmpIO%b_u_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_v_bep) ) allocate ( NoahmpIO%b_v_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_t_bep) ) allocate ( NoahmpIO%b_t_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_q_bep) ) allocate ( NoahmpIO%b_q_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%b_e_bep) ) allocate ( NoahmpIO%b_e_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%dlg_bep) ) allocate ( NoahmpIO%dlg_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%dl_u_bep) ) allocate ( NoahmpIO%dl_u_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%sf_bep) ) allocate ( NoahmpIO%sf_bep (its:ite,kts:kte ) ) + if ( .not. allocated (NoahmpIO%vl_bep) ) allocate ( NoahmpIO%vl_bep (its:ite,kts:kte ) ) + !endif + + !if(sf_urban_physics == 3) then ! bem urban model + if ( .not. allocated (NoahmpIO%tlev_urb3d) ) allocate ( NoahmpIO%tlev_urb3d (its:ite,NoahmpIO%urban_map_bd ) ) + if ( .not. allocated (NoahmpIO%qlev_urb3d) ) allocate ( NoahmpIO%qlev_urb3d (its:ite,NoahmpIO%urban_map_bd ) ) + if ( .not. allocated (NoahmpIO%tw1lev_urb3d) ) allocate ( NoahmpIO%tw1lev_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%tw2lev_urb3d) ) allocate ( NoahmpIO%tw2lev_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%tglev_urb3d) ) allocate ( NoahmpIO%tglev_urb3d (its:ite,NoahmpIO%urban_map_gbd ) ) + if ( .not. allocated (NoahmpIO%tflev_urb3d) ) allocate ( NoahmpIO%tflev_urb3d (its:ite,NoahmpIO%urban_map_fbd ) ) + if ( .not. allocated (NoahmpIO%sf_ac_urb3d) ) allocate ( NoahmpIO%sf_ac_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%lf_ac_urb3d) ) allocate ( NoahmpIO%lf_ac_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%cm_ac_urb3d) ) allocate ( NoahmpIO%cm_ac_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%sfvent_urb3d) ) allocate ( NoahmpIO%sfvent_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%lfvent_urb3d) ) allocate ( NoahmpIO%lfvent_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%sfwin1_urb3d) ) allocate ( NoahmpIO%sfwin1_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%sfwin2_urb3d) ) allocate ( NoahmpIO%sfwin2_urb3d (its:ite,NoahmpIO%urban_map_wd ) ) + if ( .not. allocated (NoahmpIO%ep_pv_urb3d) ) allocate ( NoahmpIO%ep_pv_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%t_pv_urb3d) ) allocate ( NoahmpIO%t_pv_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%trv_urb4d) ) allocate ( NoahmpIO%trv_urb4d (its:ite,NoahmpIO%urban_map_zgrd) ) + if ( .not. allocated (NoahmpIO%qr_urb4d) ) allocate ( NoahmpIO%qr_urb4d (its:ite,NoahmpIO%urban_map_zgrd) ) + if ( .not. allocated (NoahmpIO%qgr_urb3d) ) allocate ( NoahmpIO%qgr_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%tgr_urb3d) ) allocate ( NoahmpIO%tgr_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%drain_urb4d) ) allocate ( NoahmpIO%drain_urb4d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%draingr_urb3d)) allocate ( NoahmpIO%draingr_urb3d (its:ite ) ) + if ( .not. allocated (NoahmpIO%sfrv_urb3d) ) allocate ( NoahmpIO%sfrv_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%lfrv_urb3d) ) allocate ( NoahmpIO%lfrv_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%dgr_urb3d) ) allocate ( NoahmpIO%dgr_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%dg_urb3d) ) allocate ( NoahmpIO%dg_urb3d (its:ite,NoahmpIO%num_urban_ndm ) ) + if ( .not. allocated (NoahmpIO%lfr_urb3d) ) allocate ( NoahmpIO%lfr_urb3d (its:ite,NoahmpIO%urban_map_zdf ) ) + if ( .not. allocated (NoahmpIO%lfg_urb3d) ) allocate ( NoahmpIO%lfg_urb3d (its:ite,NoahmpIO%num_urban_ndm ) ) + + endif + +#ifdef WRF_HYDRO + if ( .not. allocated (NoahmpIO%infxsrt) ) allocate ( NoahmpIO%infxsrt (its:ite) ) + if ( .not. allocated (NoahmpIO%sfcheadrt) ) allocate ( NoahmpIO%sfcheadrt (its:ite) ) + if ( .not. allocated (NoahmpIO%soldrain) ) allocate ( NoahmpIO%soldrain (its:ite) ) + if ( .not. allocated (NoahmpIO%qtiledrain)) allocate ( NoahmpIO%qtiledrain (its:ite) ) + if ( .not. allocated (NoahmpIO%zwatble2d) ) allocate ( NoahmpIO%zwatble2d (its:ite) ) +#endif + + !------------------------------------------------------------------- + ! Initialize variables with default values + !------------------------------------------------------------------- + + NoahmpIO%ice = undefined_int + NoahmpIO%ivgtyp = undefined_int + NoahmpIO%isltyp = undefined_int + NoahmpIO%isnowxy = undefined_int + NoahmpIO%coszen = undefined_real + NoahmpIO%xlat = undefined_real + NoahmpIO%dz8w = undefined_real + NoahmpIO%dzs = undefined_real + NoahmpIO%zsoil = undefined_real + NoahmpIO%vegfra = undefined_real + NoahmpIO%tmn = undefined_real + NoahmpIO%xland = undefined_real + NoahmpIO%xice = undefined_real + NoahmpIO%t_phy = undefined_real + NoahmpIO%qv_curr = undefined_real + NoahmpIO%u_phy = undefined_real + NoahmpIO%v_phy = undefined_real + NoahmpIO%swdown = undefined_real + NoahmpIO%swddir = undefined_real + NoahmpIO%swddif = undefined_real + NoahmpIO%glw = undefined_real + NoahmpIO%p8w = undefined_real + NoahmpIO%rainbl = undefined_real + NoahmpIO%snowbl = undefined_real + NoahmpIO%sr = undefined_real + NoahmpIO%raincv = undefined_real + NoahmpIO%rainncv = undefined_real + NoahmpIO%rainshv = undefined_real + NoahmpIO%snowncv = undefined_real + NoahmpIO%graupelncv = undefined_real + NoahmpIO%hailncv = undefined_real + NoahmpIO%qsfc = undefined_real + NoahmpIO%tsk = undefined_real + NoahmpIO%qfx = undefined_real + NoahmpIO%smstav = undefined_real + NoahmpIO%smstot = undefined_real + NoahmpIO%smois = undefined_real + NoahmpIO%sh2o = undefined_real + NoahmpIO%tslb = undefined_real + NoahmpIO%snow = undefined_real + NoahmpIO%snowh = undefined_real + NoahmpIO%canwat = undefined_real + NoahmpIO%smoiseq = undefined_real + NoahmpIO%albedo = undefined_real + NoahmpIO%tvxy = undefined_real + NoahmpIO%tgxy = undefined_real + NoahmpIO%canicexy = undefined_real + NoahmpIO%canliqxy = undefined_real + NoahmpIO%eahxy = undefined_real + NoahmpIO%tahxy = undefined_real + NoahmpIO%cmxy = undefined_real + NoahmpIO%chxy = undefined_real + NoahmpIO%fwetxy = undefined_real + NoahmpIO%sneqvoxy = undefined_real + NoahmpIO%alboldxy = undefined_real + NoahmpIO%qsnowxy = undefined_real + NoahmpIO%qrainxy = undefined_real + NoahmpIO%wslakexy = undefined_real + NoahmpIO%zwtxy = undefined_real + NoahmpIO%waxy = undefined_real + NoahmpIO%wtxy = undefined_real + NoahmpIO%tsnoxy = undefined_real + NoahmpIO%snicexy = undefined_real + NoahmpIO%snliqxy = undefined_real + NoahmpIO%lfmassxy = undefined_real + NoahmpIO%rtmassxy = undefined_real + NoahmpIO%stmassxy = undefined_real + NoahmpIO%woodxy = undefined_real + NoahmpIO%stblcpxy = undefined_real + NoahmpIO%fastcpxy = undefined_real + NoahmpIO%lai = undefined_real + NoahmpIO%xsaixy = undefined_real + NoahmpIO%xlong = undefined_real + NoahmpIO%seaice = undefined_real + NoahmpIO%smcwtdxy = undefined_real + NoahmpIO%zsnsoxy = undefined_real + NoahmpIO%grdflx = undefined_real + NoahmpIO%hfx = undefined_real + NoahmpIO%lh = undefined_real + NoahmpIO%emiss = undefined_real + NoahmpIO%snowc = undefined_real + NoahmpIO%t2mvxy = undefined_real + NoahmpIO%t2mbxy = undefined_real + NoahmpIO%q2mvxy = undefined_real + NoahmpIO%q2mbxy = undefined_real + NoahmpIO%tradxy = undefined_real + NoahmpIO%neexy = undefined_real + NoahmpIO%gppxy = undefined_real + NoahmpIO%nppxy = undefined_real + NoahmpIO%fvegxy = undefined_real + NoahmpIO%runsfxy = undefined_real + NoahmpIO%runsbxy = undefined_real + NoahmpIO%ecanxy = undefined_real + NoahmpIO%edirxy = undefined_real + NoahmpIO%etranxy = undefined_real + NoahmpIO%fsaxy = undefined_real + NoahmpIO%firaxy = undefined_real + NoahmpIO%aparxy = undefined_real + NoahmpIO%psnxy = undefined_real + NoahmpIO%savxy = undefined_real + NoahmpIO%sagxy = undefined_real + NoahmpIO%rssunxy = undefined_real + NoahmpIO%rsshaxy = undefined_real + NoahmpIO%bgapxy = undefined_real + NoahmpIO%wgapxy = undefined_real + NoahmpIO%tgvxy = undefined_real + NoahmpIO%tgbxy = undefined_real + NoahmpIO%chvxy = undefined_real + NoahmpIO%chbxy = undefined_real + NoahmpIO%shgxy = undefined_real + NoahmpIO%shcxy = undefined_real + NoahmpIO%shbxy = undefined_real + NoahmpIO%evgxy = undefined_real + NoahmpIO%evbxy = undefined_real + NoahmpIO%ghvxy = undefined_real + NoahmpIO%ghbxy = undefined_real + NoahmpIO%irgxy = undefined_real + NoahmpIO%ircxy = undefined_real + NoahmpIO%irbxy = undefined_real + NoahmpIO%trxy = undefined_real + NoahmpIO%evcxy = undefined_real + NoahmpIO%chleafxy = undefined_real + NoahmpIO%chucxy = undefined_real + NoahmpIO%chv2xy = undefined_real + NoahmpIO%chb2xy = undefined_real + NoahmpIO%rs = undefined_real + NoahmpIO%canhsxy = undefined_real + NoahmpIO%z0 = undefined_real + NoahmpIO%znt = undefined_real + NoahmpIO%taussxy = 0.0 + NoahmpIO%deeprechxy = 0.0 + NoahmpIO%rechxy = 0.0 + NoahmpIO%acsnom = 0.0 + NoahmpIO%acsnow = 0.0 + NoahmpIO%mp_rainc = 0.0 + NoahmpIO%mp_rainnc = 0.0 + NoahmpIO%mp_shcv = 0.0 + NoahmpIO%mp_snow = 0.0 + NoahmpIO%mp_graup = 0.0 + NoahmpIO%mp_hail = 0.0 + NoahmpIO%sfcrunoff = 0.0 + NoahmpIO%udrunoff = 0.0 + + ! additional output + NoahmpIO%pahxy = undefined_real + NoahmpIO%pahgxy = undefined_real + NoahmpIO%pahbxy = undefined_real + NoahmpIO%pahvxy = undefined_real + NoahmpIO%qintsxy = undefined_real + NoahmpIO%qintrxy = undefined_real + NoahmpIO%qdripsxy = undefined_real + NoahmpIO%qdriprxy = undefined_real + NoahmpIO%qthrosxy = undefined_real + NoahmpIO%qthrorxy = undefined_real + NoahmpIO%qsnsubxy = undefined_real + NoahmpIO%qsnfroxy = undefined_real + NoahmpIO%qsubcxy = undefined_real + NoahmpIO%qfrocxy = undefined_real + NoahmpIO%qevacxy = undefined_real + NoahmpIO%qdewcxy = undefined_real + NoahmpIO%qfrzcxy = undefined_real + NoahmpIO%qmeltcxy = undefined_real + NoahmpIO%qsnbotxy = undefined_real + NoahmpIO%qmeltxy = undefined_real + NoahmpIO%fpicexy = undefined_real + NoahmpIO%rainlsm = undefined_real + NoahmpIO%snowlsm = undefined_real + NoahmpIO%forctlsm = undefined_real + NoahmpIO%forcqlsm = undefined_real + NoahmpIO%forcplsm = undefined_real + NoahmpIO%forczlsm = undefined_real + NoahmpIO%forcwlsm = undefined_real + NoahmpIO%eflxbxy = undefined_real + NoahmpIO%soilenergy = undefined_real + NoahmpIO%snowenergy = undefined_real + NoahmpIO%pondingxy = 0.0 + NoahmpIO%acc_ssoilxy = 0.0 + NoahmpIO%acc_qinsurxy = 0.0 + NoahmpIO%acc_qsevaxy = 0.0 + NoahmpIO%acc_etranixy = 0.0 + NoahmpIO%acc_dwaterxy = 0.0 + NoahmpIO%acc_prcpxy = 0.0 + NoahmpIO%acc_ecanxy = 0.0 + NoahmpIO%acc_etranxy = 0.0 + NoahmpIO%acc_edirxy = 0.0 + + ! MMF Groundwater + NoahmpIO%terrain = undefined_real + NoahmpIO%gvfmin = undefined_real + NoahmpIO%gvfmax = undefined_real + NoahmpIO%msftx = undefined_real + NoahmpIO%msfty = undefined_real + NoahmpIO%eqzwt = undefined_real + NoahmpIO%riverbedxy = undefined_real + NoahmpIO%rivercondxy = undefined_real + NoahmpIO%pexpxy = undefined_real + NoahmpIO%fdepthxy = undefined_real + NoahmpIO%areaxy = undefined_real + NoahmpIO%qrfsxy = undefined_real + NoahmpIO%qspringsxy = undefined_real + NoahmpIO%qrfxy = undefined_real + NoahmpIO%qspringxy = undefined_real + NoahmpIO%qslatxy = undefined_real + NoahmpIO%qlatxy = undefined_real + + ! crop model + NoahmpIO%pgsxy = undefined_int + NoahmpIO%cropcat = undefined_int + NoahmpIO%planting = undefined_real + NoahmpIO%harvest = undefined_real + NoahmpIO%season_gdd = undefined_real + NoahmpIO%croptype = undefined_real + + ! tile drainage + NoahmpIO%qtdrain = 0.0 + NoahmpIO%td_fraction = undefined_real + + ! irrigation + NoahmpIO%irfract = 0.0 + NoahmpIO%sifract = 0.0 + NoahmpIO%mifract = 0.0 + NoahmpIO%fifract = 0.0 + NoahmpIO%irnumsi = 0 + NoahmpIO%irnummi = 0 + NoahmpIO%irnumfi = 0 + NoahmpIO%irwatsi = 0.0 + NoahmpIO%irwatmi = 0.0 + NoahmpIO%irwatfi = 0.0 + NoahmpIO%ireloss = 0.0 + NoahmpIO%irsivol = 0.0 + NoahmpIO%irmivol = 0.0 + NoahmpIO%irfivol = 0.0 + NoahmpIO%irrsplh = 0.0 + NoahmpIO%loctim = undefined_real + + ! spatial varying soil texture + if ( NoahmpIO%iopt_soil > 1 ) then + NoahmpIO%soilcl1 = undefined_real + NoahmpIO%soilcl2 = undefined_real + NoahmpIO%soilcl3 = undefined_real + NoahmpIO%soilcl4 = undefined_real + NoahmpIO%soilcomp = undefined_real + endif + + ! urban model + if ( NoahmpIO%sf_urban_physics > 0 ) then + NoahmpIO%julday = undefined_int_neg + NoahmpIO%iri_urban = undefined_int_neg + NoahmpIO%utype_urb2d = undefined_int_neg + NoahmpIO%hrang = undefined_real_neg + NoahmpIO%declin = undefined_real_neg + NoahmpIO%sh_urb2d = undefined_real_neg + NoahmpIO%lh_urb2d = undefined_real_neg + NoahmpIO%g_urb2d = undefined_real_neg + NoahmpIO%rn_urb2d = undefined_real_neg + NoahmpIO%ts_urb2d = undefined_real_neg + NoahmpIO%gmt = undefined_real_neg + NoahmpIO%frc_urb2d = undefined_real_neg + NoahmpIO%lp_urb2d = undefined_real_neg + NoahmpIO%lb_urb2d = undefined_real_neg + NoahmpIO%hgt_urb2d = undefined_real_neg + NoahmpIO%ust = undefined_real_neg + NoahmpIO%cmr_sfcdif = 1.0e-4 + NoahmpIO%chr_sfcdif = 1.0e-4 + NoahmpIO%cmc_sfcdif = 1.0e-4 + NoahmpIO%chc_sfcdif = 1.0e-4 + NoahmpIO%cmgr_sfcdif = 1.0e-4 + NoahmpIO%chgr_sfcdif = 1.0e-4 + NoahmpIO%tr_urb2d = undefined_real_neg + NoahmpIO%tb_urb2d = undefined_real_neg + NoahmpIO%tg_urb2d = undefined_real_neg + NoahmpIO%tc_urb2d = undefined_real_neg + NoahmpIO%qc_urb2d = undefined_real_neg + NoahmpIO%uc_urb2d = undefined_real_neg + NoahmpIO%xxxr_urb2d = undefined_real_neg + NoahmpIO%xxxb_urb2d = undefined_real_neg + NoahmpIO%xxxg_urb2d = undefined_real_neg + NoahmpIO%xxxc_urb2d = undefined_real_neg + NoahmpIO%trl_urb3d = undefined_real_neg + NoahmpIO%tbl_urb3d = undefined_real_neg + NoahmpIO%tgl_urb3d = undefined_real_neg + NoahmpIO%psim_urb2d = undefined_real_neg + NoahmpIO%psih_urb2d = undefined_real_neg + NoahmpIO%u10_urb2d = undefined_real_neg + NoahmpIO%v10_urb2d = undefined_real_neg + NoahmpIO%gz1oz0_urb2d = undefined_real_neg + NoahmpIO%akms_urb2d = undefined_real_neg + NoahmpIO%th2_urb2d = undefined_real_neg + NoahmpIO%q2_urb2d = undefined_real_neg + NoahmpIO%ust_urb2d = undefined_real_neg + NoahmpIO%dzr = undefined_real_neg + NoahmpIO%dzb = undefined_real_neg + NoahmpIO%dzg = undefined_real_neg + NoahmpIO%cmcr_urb2d = undefined_real_neg + NoahmpIO%tgr_urb2d = undefined_real_neg + NoahmpIO%tgrl_urb3d = undefined_real_neg + NoahmpIO%smr_urb3d = undefined_real_neg + NoahmpIO%drelr_urb2d = undefined_real_neg + NoahmpIO%drelb_urb2d = undefined_real_neg + NoahmpIO%drelg_urb2d = undefined_real_neg + NoahmpIO%flxhumr_urb2d = undefined_real_neg + NoahmpIO%flxhumb_urb2d = undefined_real_neg + NoahmpIO%flxhumg_urb2d = undefined_real_neg + NoahmpIO%chs = 1.0e-4 + NoahmpIO%chs2 = 1.0e-4 + NoahmpIO%cqs2 = 1.0e-4 + NoahmpIO%mh_urb2d = undefined_real_neg + NoahmpIO%stdh_urb2d = undefined_real_neg + NoahmpIO%lf_urb2d = undefined_real_neg + NoahmpIO%trb_urb4d = undefined_real_neg + NoahmpIO%tw1_urb4d = undefined_real_neg + NoahmpIO%tw2_urb4d = undefined_real_neg + NoahmpIO%tgb_urb4d = undefined_real_neg + NoahmpIO%sfw1_urb3d = undefined_real_neg + NoahmpIO%sfw2_urb3d = undefined_real_neg + NoahmpIO%sfr_urb3d = undefined_real_neg + NoahmpIO%sfg_urb3d = undefined_real_neg + NoahmpIO%hi_urb2d = undefined_real_neg + NoahmpIO%theta_urban = undefined_real_neg + NoahmpIO%u_urban = undefined_real_neg + NoahmpIO%v_urban = undefined_real_neg + NoahmpIO%dz_urban = undefined_real_neg + NoahmpIO%rho_urban = undefined_real_neg + NoahmpIO%p_urban = undefined_real_neg + NoahmpIO%a_u_bep = undefined_real_neg + NoahmpIO%a_v_bep = undefined_real_neg + NoahmpIO%a_t_bep = undefined_real_neg + NoahmpIO%a_q_bep = undefined_real_neg + NoahmpIO%a_e_bep = undefined_real_neg + NoahmpIO%b_u_bep = undefined_real_neg + NoahmpIO%b_v_bep = undefined_real_neg + NoahmpIO%b_t_bep = undefined_real_neg + NoahmpIO%b_q_bep = undefined_real_neg + NoahmpIO%b_e_bep = undefined_real_neg + NoahmpIO%dlg_bep = undefined_real_neg + NoahmpIO%dl_u_bep = undefined_real_neg + NoahmpIO%sf_bep = undefined_real_neg + NoahmpIO%vl_bep = undefined_real_neg + NoahmpIO%tlev_urb3d = undefined_real_neg + NoahmpIO%qlev_urb3d = undefined_real_neg + NoahmpIO%tw1lev_urb3d = undefined_real_neg + NoahmpIO%tw2lev_urb3d = undefined_real_neg + NoahmpIO%tglev_urb3d = undefined_real_neg + NoahmpIO%tflev_urb3d = undefined_real_neg + NoahmpIO%sf_ac_urb3d = undefined_real_neg + NoahmpIO%lf_ac_urb3d = undefined_real_neg + NoahmpIO%cm_ac_urb3d = undefined_real_neg + NoahmpIO%sfvent_urb3d = undefined_real_neg + NoahmpIO%lfvent_urb3d = undefined_real_neg + NoahmpIO%sfwin1_urb3d = undefined_real_neg + NoahmpIO%sfwin2_urb3d = undefined_real_neg + NoahmpIO%ep_pv_urb3d = undefined_real_neg + NoahmpIO%t_pv_urb3d = undefined_real_neg + NoahmpIO%trv_urb4d = undefined_real_neg + NoahmpIO%qr_urb4d = undefined_real_neg + NoahmpIO%qgr_urb3d = undefined_real_neg + NoahmpIO%tgr_urb3d = undefined_real_neg + NoahmpIO%drain_urb4d = undefined_real_neg + NoahmpIO%draingr_urb3d = undefined_real_neg + NoahmpIO%sfrv_urb3d = undefined_real_neg + NoahmpIO%lfrv_urb3d = undefined_real_neg + NoahmpIO%dgr_urb3d = undefined_real_neg + NoahmpIO%dg_urb3d = undefined_real_neg + NoahmpIO%lfr_urb3d = undefined_real_neg + NoahmpIO%lfg_urb3d = undefined_real_neg + endif + + NoahmpIO%slopetyp = 1 ! soil parameter slope type + NoahmpIO%soil_update_steps = 1 ! number of model time step to update soil proces + NoahmpIO%calculate_soil = .false. ! index for if do soil process + +#ifdef WRF_HYDRO + NoahmpIO%infxsrt = 0.0 + NoahmpIO%sfcheadrt = 0.0 + NoahmpIO%soldrain = 0.0 + NoahmpIO%qtiledrain = 0.0 + NoahmpIO%zwatble2d = 0.0 +#endif + + end associate + + end subroutine NoahmpIOVarInitDefault + +end module NoahmpIOVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarType.F90 new file mode 100644 index 0000000000..0a3cd93436 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpIOVarType.F90 @@ -0,0 +1,936 @@ +module NoahmpIOVarType + +!!! Define Noah-MP Input variables (2D forcing, namelist, table, static) +!!! Input variable initialization is done in NoahmpIOVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + + type, public :: NoahmpIO_type + +!------------------------------------------------------------------------ +! general 2-D/3-D Noah-MP variables +!------------------------------------------------------------------------ + + ! IN only (as defined in WRF) + integer :: its,ite, & ! t -> tile + kts,kte ! t -> tile + integer :: itimestep ! timestep number + integer :: yr ! 4-digit year + integer :: month ! 2-digit month + integer :: day ! 2-digit day + integer :: nsoil ! number of soil layers + integer :: ice ! sea-ice point + integer :: isice ! land cover category for ice + integer :: isurban ! land cover category for urban + integer :: iswater ! land cover category for water + integer :: islake ! land cover category for lake + integer :: urbtype_beg ! urban type start number - 1 + integer :: iopt_dveg ! dynamic vegetation + integer :: iopt_crs ! canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) + integer :: iopt_btr ! soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) + integer :: iopt_runsrf ! surface runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) + integer :: iopt_runsub ! subsurface runoff option + integer :: iopt_sfc ! surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) + integer :: iopt_frz ! supercooled liquid water (1-> NY06; 2->Koren99) + integer :: iopt_inf ! frozen soil permeability (1-> NY06; 2->Koren99) + integer :: iopt_rad ! radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) + integer :: iopt_alb ! snow surface albedo (1->BATS; 2->CLASS) + integer :: iopt_snf ! rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) + integer :: iopt_tksno ! snow thermal conductivity: 1 -> Stieglitz(yen,1965) scheme (default), 2 -> Anderson, 1976 scheme, 3 -> constant, 4 -> Verseghy (1991) scheme, 5 -> Douvill(Yen, 1981) scheme + integer :: iopt_tbot ! lower boundary of soil temperature (1->zero-flux; 2->Noah) + integer :: iopt_stc ! snow/soil temperature time scheme + integer :: iopt_gla ! glacier option (1->phase change; 2->simple) + integer :: iopt_rsf ! surface resistance option (1->Zeng; 2->simple) + integer :: iz0tlnd ! option of Chen adjustment of Czil (not used) + integer :: iopt_soil ! soil configuration option + integer :: iopt_pedo ! soil pedotransfer function option + integer :: iopt_crop ! crop model option (0->none; 1->Liu et al.) + integer :: iopt_irr ! irrigation scheme (0->none; >1 irrigation scheme ON) + integer :: iopt_irrm ! irrigation method (0->dynamic; 1-> sprinkler; 2-> micro; 3-> flood) + integer :: iopt_infdv ! infiltration options for dynamic VIC (1->Philip; 2-> Green-Ampt;3->Smith-Parlange) + integer :: iopt_tdrn ! drainage option (0->off; 1->simple scheme; 2->Hooghoudt's scheme) + real(kind=kind_noahmp) :: xice_threshold ! fraction of grid determining seaice + real(kind=kind_noahmp) :: julian ! julian day + real(kind=kind_noahmp) :: dtbl ! timestep [s] + real(kind=kind_noahmp) :: dx ! horizontal grid spacing [m] + real(kind=kind_noahmp) :: soiltstep ! soil time step (s) (default=0: same as main NoahMP timstep) + logical :: fndsnowh ! snow depth present in input + logical :: calculate_soil ! logical index for if do soil calculation + integer :: soil_update_steps ! number of model time steps to update soil process + integer, allocatable, dimension(:) :: ivgtyp ! vegetation type + integer, allocatable, dimension(:) :: isltyp ! soil type + real(kind=kind_noahmp), allocatable, dimension(:) :: coszen ! cosine zenith angle + real(kind=kind_noahmp), allocatable, dimension(:) :: xlat ! latitude [rad] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dz8w ! thickness of atmo layers [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: dzs ! thickness of soil layers [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: zsoil ! depth to soil interfaces [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: vegfra ! vegetation fraction [] + real(kind=kind_noahmp), allocatable, dimension(:) :: tmn ! deep soil temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: xland ! =2 ocean; =1 land/seaice + real(kind=kind_noahmp), allocatable, dimension(:) :: xice ! fraction of grid that is seaice + real(kind=kind_noahmp), allocatable, dimension(:) :: seaice ! seaice fraction + + ! forcings + real(kind=kind_noahmp), allocatable, dimension(:,:) :: t_phy ! 3D atmospheric temperature valid at mid-levels [K] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: qv_curr ! 3D water vapor mixing ratio [kg/kg_dry] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: u_phy ! 3D U wind component [m/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: v_phy ! 3D V wind component [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: swdown ! solar down at surface [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: glw ! longwave down at surface [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: p8w ! 3D pressure, valid at interface [Pa] + real(kind=kind_noahmp), allocatable, dimension(:) :: rainbl ! precipitation entering land model [mm] per time step + real(kind=kind_noahmp), allocatable, dimension(:) :: snowbl ! snow entering land model [mm] per time step + real(kind=kind_noahmp), allocatable, dimension(:) :: sr ! frozen precip ratio entering land model [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: raincv ! convective precip forcing [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: rainncv ! non-convective precip forcing [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: rainshv ! shallow conv. precip forcing [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowncv ! non-covective snow forcing (subset of rainncv) [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: graupelncv ! non-convective graupel forcing (subset of rainncv) [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: hailncv ! non-convective hail forcing (subset of rainncv) [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_rainc ! convective precipitation entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_rainnc ! large-scale precipitation entering land model [mm]! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_shcv ! shallow conv precip entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_snow ! snow precipitation entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_graup ! graupel precipitation entering land model [mm] ! MB/AN : v3.7 + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_hail ! hail precipitation entering land model [mm] ! MB/AN : v3.7 + +#ifdef WRF_HYDRO + real(kind=kind_noahmp), allocatable, dimension(:) :: infxsrt ! surface infiltration + real(kind=kind_noahmp), allocatable, dimension(:) :: sfcheadrt ! surface water head + real(kind=kind_noahmp), allocatable, dimension(:) :: soldrain ! soil drainage + real(kind=kind_noahmp), allocatable, dimension(:) :: qtiledrain ! tile drainage + real(kind=kind_noahmp), allocatable, dimension(:) :: zwatble2d ! water table depth +#endif + + ! Spatially varying fields (for now it is de-activated) + real(kind=kind_noahmp), allocatable, dimension(:,:) :: soilcomp ! Soil sand and clay content [fraction] + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl1 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl2 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl3 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:) :: soilcl4 ! Soil texture class with depth + real(kind=kind_noahmp), allocatable, dimension(:,:) :: bexp_3D ! C-H B exponent + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcdry_3D ! Soil Moisture Limit: Dry + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcwlt_3D ! Soil Moisture Limit: Wilt + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcref_3D ! Soil Moisture Limit: Reference + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smcmax_3D ! Soil Moisture Limit: Max + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dksat_3D ! Saturated Soil Conductivity + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dwsat_3D ! Saturated Soil Diffusivity + real(kind=kind_noahmp), allocatable, dimension(:,:) :: psisat_3D ! Saturated Matric Potential + real(kind=kind_noahmp), allocatable, dimension(:,:) :: quartz_3D ! Soil quartz content + real(kind=kind_noahmp), allocatable, dimension(:) :: refdk_2D ! Reference Soil Conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: refkdt_2D ! Soil Infiltration Parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_frac_2D ! irrigation Fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_har_2D ! number of days before harvest date to stop irrigation + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_lai_2D ! Minimum lai to trigger irrigation + real(kind=kind_noahmp), allocatable, dimension(:) :: irr_mad_2D ! management allowable deficit (0-1) + real(kind=kind_noahmp), allocatable, dimension(:) :: filoss_2D ! fraction of flood irrigation loss (0-1) + real(kind=kind_noahmp), allocatable, dimension(:) :: sprir_rate_2D ! mm/h, sprinkler irrigation rate + real(kind=kind_noahmp), allocatable, dimension(:) :: micir_rate_2D ! mm/h, micro irrigation rate + real(kind=kind_noahmp), allocatable, dimension(:) :: firtfac_2D ! flood application rate factor + real(kind=kind_noahmp), allocatable, dimension(:) :: ir_rain_2D ! maximum precipitation to stop irrigation trigger + real(kind=kind_noahmp), allocatable, dimension(:) :: bvic_2d ! VIC model infiltration parameter [-] opt_run=6 + real(kind=kind_noahmp), allocatable, dimension(:) :: axaj_2D ! Tension water distribution inflection parameter [-] opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bxaj_2D ! Tension water distribution shape parameter [-] opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: xxaj_2D ! Free water distribution shape parameter [-] opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bdvic_2d ! VIC model infiltration parameter [-] opt_run=8 + real(kind=kind_noahmp), allocatable, dimension(:) :: gdvic_2d ! Mean Capillary Drive (m) for infiltration models opt_run=8 + real(kind=kind_noahmp), allocatable, dimension(:) :: bbvic_2d ! DVIC heterogeniety parameter for infiltration [-] opt_run=8 + real(kind=kind_noahmp), allocatable, dimension(:) :: KLAT_FAC ! factor multiplier to hydraulic conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: TDSMC_FAC ! factor multiplier to field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_DC ! drainage coefficient for simple + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_DCOEF ! drainge coefficient for Hooghoudt + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_DDRAIN ! depth of drain + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_RADI ! tile radius + real(kind=kind_noahmp), allocatable, dimension(:) :: TD_SPAC ! tile spacing + + ! INOUT (with generic LSM equivalent) (as defined in WRF) + real(kind=kind_noahmp), allocatable, dimension(:) :: tsk ! surface radiative temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: hfx ! sensible heat flux [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: qfx ! latent heat flux [kg s-1 m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: lh ! latent heat flux [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: grdflx ! ground/snow heat flux [W m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: smstav ! soil moisture avail. [not used] + real(kind=kind_noahmp), allocatable, dimension(:) :: smstot ! total soil water [mm][not used] + real(kind=kind_noahmp), allocatable, dimension(:) :: sfcrunoff ! accumulated surface runoff [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: udrunoff ! accumulated sub-surface runoff [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: albedo ! total grid albedo [] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowc ! snow cover fraction [] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smoiseq ! volumetric soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smois ! volumetric soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sh2o ! volumetric liquid soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tslb ! soil temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: snow ! snow water equivalent [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowh ! physical snow depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: canwat ! total canopy water + ice [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acsnom ! accumulated snow melt leaving pack + real(kind=kind_noahmp), allocatable, dimension(:) :: acsnow ! accumulated snow on grid + real(kind=kind_noahmp), allocatable, dimension(:) :: emiss ! surface bulk emissivity + real(kind=kind_noahmp), allocatable, dimension(:) :: qsfc ! bulk surface specific humidity + + ! INOUT (with no Noah LSM equivalent) (as defined in WRF) + integer, allocatable, dimension(:) :: isnowxy ! actual no. of snow layers + real(kind=kind_noahmp), allocatable, dimension(:) :: tvxy ! vegetation leaf temperature + real(kind=kind_noahmp), allocatable, dimension(:) :: tgxy ! bulk ground surface temperature + real(kind=kind_noahmp), allocatable, dimension(:) :: canicexy ! canopy-intercepted ice (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: canliqxy ! canopy-intercepted liquid water (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: eahxy ! canopy air vapor pressure (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: tahxy ! canopy air temperature (K) + real(kind=kind_noahmp), allocatable, dimension(:) :: cmxy ! bulk momentum drag coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chxy ! bulk sensible heat exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: fwetxy ! wetted or snowed fraction of the canopy (-) + real(kind=kind_noahmp), allocatable, dimension(:) :: sneqvoxy ! snow mass at last time step(mm h2o) + real(kind=kind_noahmp), allocatable, dimension(:) :: alboldxy ! snow albedo at last time step (-) + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnowxy ! snowfall on the ground [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qrainxy ! rainfall on the ground [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: wslakexy ! lake water storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: zwtxy ! water table depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: waxy ! water in the "aquifer" [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: wtxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: smcwtdxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: deeprechxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: rechxy ! groundwater storage [mm] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tsnoxy ! snow temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: zsnsoxy ! snow layer depth [m] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: snicexy ! snow layer ice [mm] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: snliqxy ! snow layer liquid water [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: lfmassxy ! leaf mass [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: rtmassxy ! mass of fine roots [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: stmassxy ! stem mass [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: woodxy ! mass of wood (incl. woody roots) [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: grainxy ! xing mass of grain!three + real(kind=kind_noahmp), allocatable, dimension(:) :: gddxy ! xinggrowingdegressday + real(kind=kind_noahmp), allocatable, dimension(:) :: stblcpxy ! stable carbon in deep soil [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: fastcpxy ! short-lived carbon, shallow soil [g/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: lai ! leaf area index + real(kind=kind_noahmp), allocatable, dimension(:) :: xsaixy ! stem area index + real(kind=kind_noahmp), allocatable, dimension(:) :: taussxy ! snow age factor + + ! irrigation + real(kind=kind_noahmp), allocatable, dimension(:) :: irfract ! irrigation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: sifract ! sprinkler irrigation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: mifract ! micro irrigation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: fifract ! flood irrigation fraction + integer, allocatable, dimension(:) :: irnumsi ! irrigation event number, sprinkler + integer, allocatable, dimension(:) :: irnummi ! irrigation event number, micro + integer, allocatable, dimension(:) :: irnumfi ! irrigation event number, flood + real(kind=kind_noahmp), allocatable, dimension(:) :: irwatsi ! irrigation water amount [m] to be applied, sprinkler + real(kind=kind_noahmp), allocatable, dimension(:) :: irwatmi ! irrigation water amount [m] to be applied, micro + real(kind=kind_noahmp), allocatable, dimension(:) :: irwatfi ! irrigation water amount [m] to be applied, flood + real(kind=kind_noahmp), allocatable, dimension(:) :: ireloss ! loss of irrigation water to evaporation,sprinkler [m/timestep] + real(kind=kind_noahmp), allocatable, dimension(:) :: irsivol ! amount of irrigation by sprinkler (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: irmivol ! amount of irrigation by micro (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: irfivol ! amount of irrigation by micro (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: irrsplh ! latent heating from sprinkler evaporation (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: loctim ! local time + + ! OUT (with no Noah LSM equivalent) (as defined in WRF) + real(kind=kind_noahmp), allocatable, dimension(:) :: t2mvxy ! 2m temperature of vegetation part + real(kind=kind_noahmp), allocatable, dimension(:) :: t2mbxy ! 2m temperature of bare ground part + real(kind=kind_noahmp), allocatable, dimension(:) :: q2mvxy ! 2m mixing ratio of vegetation part + real(kind=kind_noahmp), allocatable, dimension(:) :: q2mbxy ! 2m mixing ratio of bare ground part + real(kind=kind_noahmp), allocatable, dimension(:) :: tradxy ! surface radiative temperature (K) + real(kind=kind_noahmp), allocatable, dimension(:) :: neexy ! net ecosys exchange (g/m2/s CO2) + real(kind=kind_noahmp), allocatable, dimension(:) :: gppxy ! gross primary assimilation [g/m2/s C] + real(kind=kind_noahmp), allocatable, dimension(:) :: nppxy ! net primary productivity [g/m2/s C] + real(kind=kind_noahmp), allocatable, dimension(:) :: fvegxy ! noah-mp vegetation fraction [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: runsfxy ! surface runoff [mm per soil timestep] + real(kind=kind_noahmp), allocatable, dimension(:) :: runsbxy ! subsurface runoff [mm per soil timestep] + real(kind=kind_noahmp), allocatable, dimension(:) :: ecanxy ! evaporation of intercepted water (mm/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: edirxy ! soil surface evaporation rate (mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: etranxy ! transpiration rate (mm/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: fsaxy ! total absorbed solar radiation (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: firaxy ! total net longwave rad (w/m2) [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: aparxy ! photosyn active energy by canopy (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: psnxy ! total photosynthesis (umol co2/m2/s) [+] + real(kind=kind_noahmp), allocatable, dimension(:) :: savxy ! solar rad absorbed by veg. (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: sagxy ! solar rad absorbed by ground (W/m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: rssunxy ! sunlit leaf stomatal resistance (s/m) + real(kind=kind_noahmp), allocatable, dimension(:) :: rsshaxy ! shaded leaf stomatal resistance (s/m) + real(kind=kind_noahmp), allocatable, dimension(:) :: bgapxy ! between gap fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: wgapxy ! within gap fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: tgvxy ! under canopy ground temperature[K] + real(kind=kind_noahmp), allocatable, dimension(:) :: tgbxy ! bare ground temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: chvxy ! sensible heat exchange coefficient vegetated + real(kind=kind_noahmp), allocatable, dimension(:) :: chbxy ! sensible heat exchange coefficient bare-ground + real(kind=kind_noahmp), allocatable, dimension(:) :: shgxy ! veg ground sen. heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: shcxy ! canopy sen. heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: shbxy ! bare sensible heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: evgxy ! veg ground evap. heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: evbxy ! bare soil evaporation [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: ghvxy ! veg ground heat flux [W/m2] [+ to soil] + real(kind=kind_noahmp), allocatable, dimension(:) :: ghbxy ! bare ground heat flux [W/m2] [+ to soil] + real(kind=kind_noahmp), allocatable, dimension(:) :: irgxy ! veg ground net lw rad. [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: ircxy ! canopy net lw rad. [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: irbxy ! bare net longwave rad. [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: trxy ! transpiration [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: evcxy ! canopy evaporation heat [W/m2] [+ to atm] + real(kind=kind_noahmp), allocatable, dimension(:) :: chleafxy ! leaf exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chucxy ! under canopy exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chv2xy ! veg 2m exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: chb2xy ! bare 2m exchange coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: rs ! total stomatal resistance [s/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: z0 ! roughness length output to wrf + real(kind=kind_noahmp), allocatable, dimension(:) :: znt ! roughness length output to wrf + real(kind=kind_noahmp), allocatable, dimension(:) :: qtdrain ! tile drain discharge [mm] + + ! additional output variables + real(kind=kind_noahmp), allocatable, dimension(:) :: pahxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: pahgxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: pahbxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: pahvxy ! precipitation advected heat [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: qintsxy ! canopy intercepted snow [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qintrxy ! canopy intercepted rain [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qdripsxy ! canopy dripping snow [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qdriprxy ! canopy dripping rain [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qthrosxy ! canopy throughfall snow [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qthrorxy ! canopy throughfall rain [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnsubxy ! snowpack sublimation rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qmeltxy ! snowpack melting rate due to phase change [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnfroxy ! snowpack frost rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsubcxy ! canopy snow sublimation rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qfrocxy ! canopy snow frost rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qevacxy ! canopy water evaporation rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qdewcxy ! canopy water dew rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qfrzcxy ! canopy water freezing rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qmeltcxy ! canopy snow melting rate [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: qsnbotxy ! total water (melt+rain through snow) out of snowpack bottom [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: pondingxy ! total surface ponding [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: fpicexy ! fraction of ice in total precipitation + real(kind=kind_noahmp), allocatable, dimension(:) :: rainlsm ! total rain rate at the surface [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowlsm ! total snow rate at the surface [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: forctlsm ! surface temperature as lsm forcing [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: forcqlsm ! surface specific humidity as lsm forcing [kg/kg] + real(kind=kind_noahmp), allocatable, dimension(:) :: forcplsm ! surface pressure as lsm forcing [Pa] + real(kind=kind_noahmp), allocatable, dimension(:) :: forczlsm ! reference height as lsm input [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: forcwlsm ! surface wind speed as lsm forcing [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_ssoilxy ! accumulated ground heat flux [W/m2 * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_qinsurxy ! accumulated water flux into soil [m/s * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_qsevaxy ! accumulated soil surface evaporation [m/s * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: eflxbxy ! accumulated heat flux through soil bottom per soil timestep [J/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: soilenergy ! energy content in soil relative to 273.16 [kJ/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: snowenergy ! energy content in snow relative to 273.16 [kJ/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: canhsxy ! canopy heat storage change [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_dwaterxy ! accumulated snow,soil,canopy water change per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_prcpxy ! accumulated precipitation per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_ecanxy ! accumulated net canopy evaporation per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_etranxy ! accumulated transpiration per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: acc_edirxy ! accumulated net ground (soil/snow) evaporation per soil timestep [mm] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: acc_etranixy ! accumualted transpiration rate within soil timestep [m/s * dt_soil/dt_main] + +!------------------------------------------------------------------------ +! Needed for MMF_RUNOFF (IOPT_RUN = 5); not part of MP driver in WRF +!------------------------------------------------------------------------ + + real(kind=kind_noahmp), allocatable, dimension(:) :: msftx ! mapping factor x + real(kind=kind_noahmp), allocatable, dimension(:) :: msfty ! mapping factor y + real(kind=kind_noahmp), allocatable, dimension(:) :: eqzwt ! equilibrium water table + real(kind=kind_noahmp), allocatable, dimension(:) :: riverbedxy ! riverbed depth + real(kind=kind_noahmp), allocatable, dimension(:) :: rivercondxy ! river conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: pexpxy ! exponential factor + real(kind=kind_noahmp), allocatable, dimension(:) :: fdepthxy ! depth + real(kind=kind_noahmp), allocatable, dimension(:) :: areaxy ! river area + real(kind=kind_noahmp), allocatable, dimension(:) :: qrfsxy ! accumulated groundwater baseflow [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: qspringsxy ! accumulated seeping water [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: qrfxy ! groundwater baselow [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: qspringxy ! seeping water [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: qslatxy ! accumulated lateral flow [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: qlatxy ! lateral flow [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: rechclim ! climatology recharge + real(kind=kind_noahmp), allocatable, dimension(:) :: rivermask ! river mask + real(kind=kind_noahmp), allocatable, dimension(:) :: nonriverxy ! non-river portion + real(kind=kind_noahmp) :: wtddt = 30.0 ! frequency of groundwater call [minutes] + integer :: stepwtd ! step of groundwater call + +!------------------------------------------------------------------------ +! Needed for TILE DRAINAGE IF IOPT_TDRN = 1 OR 2 +!------------------------------------------------------------------------ + real(kind=kind_noahmp), allocatable, dimension(:) :: td_fraction ! tile drainage fraction + +!------------------------------------------------------------------------ +! Needed for crop model (OPT_CROP=1) +!------------------------------------------------------------------------ + + integer, allocatable, dimension(:) :: pgsxy ! plant growth stage + integer, allocatable, dimension(:) :: cropcat ! crop category + real(kind=kind_noahmp), allocatable, dimension(:) :: planting ! planting day + real(kind=kind_noahmp), allocatable, dimension(:) :: harvest ! harvest day + real(kind=kind_noahmp), allocatable, dimension(:) :: season_gdd ! seasonal gdd + real(kind=kind_noahmp), allocatable, dimension(:,:) :: croptype ! crop type + +!------------------------------------------------------------------------ +! Single- and Multi-layer Urban Models +!------------------------------------------------------------------------ + + integer :: num_urban_atmosphere ! atmospheric levels including ZLVL for BEP/BEM models + integer :: iri_urban ! urban irrigation flag (move from module_sf_urban to here) + real(kind=kind_noahmp) :: gmt ! hour of day (fractional) (needed for urban) + integer :: julday ! integer day (needed for urban) + real(kind=kind_noahmp), allocatable, dimension(:) :: hrang ! hour angle (needed for urban) + real(kind=kind_noahmp) :: declin ! declination (needed for urban) + integer :: num_roof_layers = 4 ! roof layer number + integer :: num_road_layers = 4 ! road layer number + integer :: num_wall_layers = 4 ! wall layer number + real(kind=kind_noahmp), allocatable, dimension(:) :: cmr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: chr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: cmc_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: chc_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: cmgr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: chgr_sfcdif + real(kind=kind_noahmp), allocatable, dimension(:) :: tr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: qc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: uc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: xxxc_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: trl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tbl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tgl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: sh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: lh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: g_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: rn_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: ts_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: psim_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: psih_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: u10_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: v10_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: gz1oz0_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: akms_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: th2_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: q2_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: ust_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: dzr + real(kind=kind_noahmp), allocatable, dimension(:) :: dzb + real(kind=kind_noahmp), allocatable, dimension(:) :: dzg + real(kind=kind_noahmp), allocatable, dimension(:) :: cmcr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: tgr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tgrl_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: smr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: drelr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: drelb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: drelg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: flxhumr_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: flxhumb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: flxhumg_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: frc_urb2d + integer, allocatable, dimension(:) :: utype_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: chs + real(kind=kind_noahmp), allocatable, dimension(:) :: chs2 + real(kind=kind_noahmp), allocatable, dimension(:) :: cqs2 + real(kind=kind_noahmp), allocatable, dimension(:,:) :: trb_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw1_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw2_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tgb_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tlev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: qlev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw1lev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tw2lev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tglev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: tflev_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: sf_ac_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: lf_ac_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: cm_ac_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: sfvent_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: lfvent_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfwin1_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfwin2_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfw1_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfw2_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfg_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: lp_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: hi_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: lb_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: hgt_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: mh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:) :: stdh_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lf_urb2d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: theta_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: u_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: v_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dz_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rho_urban + real(kind=kind_noahmp), allocatable, dimension(:,:) :: p_urban + real(kind=kind_noahmp), allocatable, dimension(:) :: ust + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_u_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_v_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_t_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_q_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: a_e_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_u_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_v_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_t_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_q_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: b_e_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dlg_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dl_u_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sf_bep + real(kind=kind_noahmp), allocatable, dimension(:,:) :: vl_bep + real(kind=kind_noahmp) :: height_urban + + ! new urban variables for green roof, PVP for BEP_BEM scheme=3, Zonato et al., 2021 + real(kind=kind_noahmp), allocatable, dimension(:) :: ep_pv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: qgr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: tgr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: draingr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: t_pv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: trv_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: qr_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: drain_urb4d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: sfrv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfrv_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dgr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dg_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfr_urb3d + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfg_urb3d + real(kind=kind_noahmp), allocatable, dimension(:) :: swddir ! solar down at surface [w m-2] + real(kind=kind_noahmp), allocatable, dimension(:) :: swddif + +!------------------------------------------------------------------------ +! 2D variables not used in WRF - should be removed? +!------------------------------------------------------------------------ + + real(kind=kind_noahmp), allocatable, dimension(:) :: xlong ! longitude + real(kind=kind_noahmp), allocatable, dimension(:) :: terrain ! terrain height + real(kind=kind_noahmp), allocatable, dimension(:) :: gvfmin ! annual minimum in vegetation fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: gvfmax ! annual maximum in vegetation fraction + +!------------------------------------------------------------------------ +! End 2D variables not used in WRF +!------------------------------------------------------------------------ + + CHARACTER(LEN=256) :: mminsl = 'STAS' ! soil classification + CHARACTER(LEN=256) :: llanduse ! (=USGS, using USGS landuse classification) + +!------------------------------------------------------------------------ +! Timing: +!------------------------------------------------------------------------ + + integer :: ntime ! timesteps + integer :: clock_count_1 = 0 + integer :: clock_count_2 = 0 + integer :: clock_rate = 0 + real(kind=kind_noahmp) :: timing_sum = 0.0 + integer :: sflx_count_sum + integer :: count_before_sflx + integer :: count_after_sflx + +!--------------------------------------------------------------------- +! DECLARE/Initialize constants +!--------------------------------------------------------------------- + + integer :: i + integer :: j + integer :: slopetyp + integer :: yearlen + integer :: nsnow + logical :: update_lai, update_veg + integer :: spinup_loop + logical :: reset_spinup_date + +!--------------------------------------------------------------------- +! File naming, parallel +!--------------------------------------------------------------------- + + character(len=19) :: olddate, & + newdate, & + startdate + character :: hgrid + integer :: igrid + logical :: lexist + integer :: imode + integer :: ixfull + integer :: jxfull + integer :: ixpar + integer :: jxpar + integer :: ystartpar + integer :: rank = 0 + character(len=256) :: inflnm, & + outflnm, & + inflnm_template + logical :: restart_flag + character(len=256) :: restart_flnm + integer :: ierr + +!--------------------------------------------------------------------- +! Attributes from LDASIN input file (or HRLDAS_SETUP_FILE, as the case may be) +!--------------------------------------------------------------------- + + integer :: ix + integer :: jx + real(kind=kind_noahmp) :: dy + real(kind=kind_noahmp) :: truelat1 + real(kind=kind_noahmp) :: truelat2 + real(kind=kind_noahmp) :: cen_lon + integer :: mapproj + real(kind=kind_noahmp) :: lat1 + real(kind=kind_noahmp) :: lon1 + +!--------------------------------------------------------------------- +! NAMELIST start +!--------------------------------------------------------------------- + + character(len=256) :: indir + ! nsoil defined above + integer :: forcing_timestep + integer :: noah_timestep + integer :: start_year + integer :: start_month + integer :: start_day + integer :: start_hour + integer :: start_min + character(len=256) :: outdir + character(len=256) :: restart_filename_requested + integer :: restart_frequency_hours + integer :: output_timestep + integer :: spinup_loops + + integer :: sf_urban_physics + integer :: use_wudapt_lcz + integer :: num_urban_ndm + integer :: num_urban_ng + integer :: num_urban_nwr + integer :: num_urban_ngb + integer :: num_urban_nf + integer :: num_urban_nz + integer :: num_urban_nbui + integer :: num_urban_hi + integer :: num_urban_ngr + real(kind=kind_noahmp) :: urban_atmosphere_thickness + + ! derived urban dimensions + integer :: urban_map_zrd + integer :: urban_map_zwd + integer :: urban_map_gd + integer :: urban_map_zd + integer :: urban_map_zdf + integer :: urban_map_bd + integer :: urban_map_wd + integer :: urban_map_gbd + integer :: urban_map_fbd + integer :: urban_map_zgrd + integer :: max_urban_dim ! C. He: maximum urban dimension for urban variable + + character(len=256) :: forcing_name_T + character(len=256) :: forcing_name_Q + character(len=256) :: forcing_name_U + character(len=256) :: forcing_name_V + character(len=256) :: forcing_name_P + character(len=256) :: forcing_name_LW + character(len=256) :: forcing_name_SW + character(len=256) :: forcing_name_PR + character(len=256) :: forcing_name_SN + + integer :: noahmp_output ! =0: default output; >0 include additional output + integer :: split_output_count + logical :: skip_first_output + integer :: khour + integer :: kday + real(kind=kind_noahmp) :: zlvl + character(len=256) :: hrldas_setup_file + character(len=256) :: spatial_filename + character(len=256) :: external_veg_filename_template + character(len=256) :: external_lai_filename_template + character(len=256) :: agdata_flnm + character(len=256) :: tdinput_flnm + integer :: MAX_SOIL_LEVELS + real(kind=kind_noahmp), allocatable, dimension(:) :: soil_thick_input + +!---------------------------------------------------------------- +! Noahmp Parameters Table +!---------------------------------------------------------------- + + ! vegetation parameters + character(len=256) :: veg_dataset_description_table + integer :: nveg_table ! number of vegetation types + integer :: isurban_table ! urban flag + integer :: iswater_table ! water flag + integer :: isbarren_table ! barren ground flag + integer :: isice_table ! ice flag + integer :: iscrop_table ! cropland flag + integer :: eblforest_table ! evergreen broadleaf forest flag + integer :: natural_table ! natural vegetation type + integer :: lcz_1_table ! urban lcz 1 + integer :: lcz_2_table ! urban lcz 2 + integer :: lcz_3_table ! urban lcz 3 + integer :: lcz_4_table ! urban lcz 4 + integer :: lcz_5_table ! urban lcz 5 + integer :: lcz_6_table ! urban lcz 6 + integer :: lcz_7_table ! urban lcz 7 + integer :: lcz_8_table ! urban lcz 8 + integer :: lcz_9_table ! urban lcz 9 + integer :: lcz_10_table ! urban lcz 10 + integer :: lcz_11_table ! urban lcz 11 + real(kind=kind_noahmp), allocatable, dimension(:) :: ch2op_table ! maximum intercepted h2o per unit lai+sai (mm) + real(kind=kind_noahmp), allocatable, dimension(:) :: dleaf_table ! characteristic leaf dimension (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: z0mvt_table ! momentum roughness length (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: hvt_table ! top of canopy (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: hvb_table ! bottom of canopy (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: den_table ! tree density (no. of trunks per m2) + real(kind=kind_noahmp), allocatable, dimension(:) :: rc_table ! tree crown radius (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: mfsno_table ! snowmelt curve parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: scffac_table ! snow cover factor (m) (replace original hard-coded 2.5*z0 in SCF formulation) + real(kind=kind_noahmp), allocatable, dimension(:) :: cbiom_table ! canopy biomass heat capacity parameter (m) + real(kind=kind_noahmp), allocatable, dimension(:,:) :: saim_table ! monthly stem area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:,:) :: laim_table ! monthly leaf area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:) :: sla_table ! single-side leaf area per kg [m2/kg] + real(kind=kind_noahmp), allocatable, dimension(:) :: dilefc_table ! coeficient for leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: dilefw_table ! coeficient for leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: fragr_table ! fraction of growth respiration !original was 0.3 + real(kind=kind_noahmp), allocatable, dimension(:) :: ltovrc_table ! leaf turnover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: c3psn_table ! photosynthetic pathway: 0. = c4, 1. = c3 + real(kind=kind_noahmp), allocatable, dimension(:) :: kc25_table ! co2 michaelis-menten constant at 25C (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: akc_table ! q10 for kc25 + real(kind=kind_noahmp), allocatable, dimension(:) :: ko25_table ! o2 michaelis-menten constant at 25C (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: ako_table ! q10 for ko25 + real(kind=kind_noahmp), allocatable, dimension(:) :: vcmx25_table ! maximum rate of carboxylation at 25C (umol CO2/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: avcmx_table ! q10 for vcmx25 + real(kind=kind_noahmp), allocatable, dimension(:) :: bp_table ! minimum leaf conductance (umol/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: mp_table ! slope of conductance-to-photosynthesis relationship + real(kind=kind_noahmp), allocatable, dimension(:) :: qe25_table ! quantum efficiency at 25C (umol CO2 / umol photon) + real(kind=kind_noahmp), allocatable, dimension(:) :: aqe_table ! q10 for qe25 + real(kind=kind_noahmp), allocatable, dimension(:) :: rmf25_table ! leaf maintenance respiration at 25C (umol CO2/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: rms25_table ! stem maintenance respiration at 25C (umol CO2/kg bio/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: rmr25_table ! root maintenance respiration at 25C (umol CO2/kg bio/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: arm_table ! q10 for maintenance respiration + real(kind=kind_noahmp), allocatable, dimension(:) :: folnmx_table ! foliage nitrogen concentration when f(n)=1 (%) + real(kind=kind_noahmp), allocatable, dimension(:) :: tmin_table ! minimum temperature for photosynthesis (K) + real(kind=kind_noahmp), allocatable, dimension(:) :: xl_table ! leaf/stem orientation index + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rhol_table ! leaf reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rhos_table ! stem reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: taul_table ! leaf transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: taus_table ! stem transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: mrp_table ! microbial respiration parameter (umol CO2 /kg c/ s) + real(kind=kind_noahmp), allocatable, dimension(:) :: cwpvt_table ! empirical canopy wind parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: wrrat_table ! wood to non-wood ratio + real(kind=kind_noahmp), allocatable, dimension(:) :: wdpool_table ! wood pool (switch 1 or 0) depending on woody or not [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: tdlef_table ! characteristic t for leaf freezing [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: nroot_table ! number of soil layers with root present + real(kind=kind_noahmp), allocatable, dimension(:) :: rgl_table ! parameter used in radiation stress function + real(kind=kind_noahmp), allocatable, dimension(:) :: rs_table ! minimum stomatal resistance [s m-1] + real(kind=kind_noahmp), allocatable, dimension(:) :: hs_table ! parameter used in vapor pressure deficit function + real(kind=kind_noahmp), allocatable, dimension(:) :: topt_table ! optimum transpiration air temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: rsmax_table ! maximal stomatal resistance [s m-1] + real(kind=kind_noahmp), allocatable, dimension(:) :: rtovrc_table ! root turnover coefficient [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: rswoodc_table ! wood respiration coeficient [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: bf_table ! parameter for present wood allocation [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: wstrc_table ! water stress coeficient [-] + real(kind=kind_noahmp), allocatable, dimension(:) :: laimin_table ! minimum leaf area index [m2/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: xsamin_table ! minimum stem area index [m2/m2] + + ! radiation parameters + real(kind=kind_noahmp), allocatable, dimension(:,:) :: albsat_table ! saturated soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:,:) :: albdry_table ! dry soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: albice_table ! albedo land ice: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: alblak_table ! albedo frozen lakes: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: omegas_table ! two-stream parameter omega for snow + real(kind=kind_noahmp) :: betads_table ! two-stream parameter betad for snow + real(kind=kind_noahmp) :: betais_table ! two-stream parameter betad for snow + real(kind=kind_noahmp), allocatable, dimension(:) :: eg_table ! emissivity soil surface + real(kind=kind_noahmp) :: eice_table ! ice surface emissivity + + ! global parameters + real(kind=kind_noahmp) :: co2_table ! co2 partial pressure + real(kind=kind_noahmp) :: o2_table ! o2 partial pressure + real(kind=kind_noahmp) :: timean_table ! gridcell mean topgraphic index (global mean) + real(kind=kind_noahmp) :: fsatmx_table ! maximum surface saturated fraction (global mean) + real(kind=kind_noahmp) :: z0sno_table ! snow surface roughness length (m) (0.002) + real(kind=kind_noahmp) :: ssi_table ! liquid water holding capacity for snowpack (m3/m3) (0.03) + real(kind=kind_noahmp) :: snow_ret_fac_table ! snowpack water release timescale factor (1/s) + real(kind=kind_noahmp) :: snow_emis_table ! snow emissivity + real(kind=kind_noahmp) :: swemx_table ! new snow mass to fully cover old snow (mm) + real(kind=kind_noahmp) :: tau0_table ! tau0 from Yang97 eqn. 10a + real(kind=kind_noahmp) :: grain_growth_table ! growth from vapor diffusion Yang97 eqn. 10b + real(kind=kind_noahmp) :: extra_growth_table ! extra growth near freezing Yang97 eqn. 10c + real(kind=kind_noahmp) :: dirt_soot_table ! dirt and soot term Yang97 eqn. 10d + real(kind=kind_noahmp) :: bats_cosz_table ! zenith angle snow albedo adjustment; b in Yang97 eqn. 15 + real(kind=kind_noahmp) :: bats_vis_new_table ! new snow visible albedo + real(kind=kind_noahmp) :: bats_nir_new_table ! new snow nir albedo + real(kind=kind_noahmp) :: bats_vis_age_table ! age factor for diffuse visible snow albedo Yang97 eqn. 17 + real(kind=kind_noahmp) :: bats_nir_age_table ! age factor for diffuse nir snow albedo Yang97 eqn. 18 + real(kind=kind_noahmp) :: bats_vis_dir_table ! cosz factor for direct visible snow albedo Yang97 eqn. 15 + real(kind=kind_noahmp) :: bats_nir_dir_table ! cosz factor for direct nir snow albedo Yang97 eqn. 16 + real(kind=kind_noahmp) :: rsurf_snow_table ! surface resistance for snow(s/m) + real(kind=kind_noahmp) :: rsurf_exp_table ! exponent in the shape parameter for soil resistance option 1 + real(kind=kind_noahmp) :: c2_snowcompact_table ! overburden snow compaction parameter (m3/kg) + real(kind=kind_noahmp) :: c3_snowcompact_table ! snow desctructive metamorphism compaction parameter1 [1/s] + real(kind=kind_noahmp) :: c4_snowcompact_table ! snow desctructive metamorphism compaction parameter2 [1/k] + real(kind=kind_noahmp) :: c5_snowcompact_table ! snow desctructive metamorphism compaction parameter3 + real(kind=kind_noahmp) :: dm_snowcompact_table ! upper limit on destructive metamorphism compaction [kg/m3] + real(kind=kind_noahmp) :: eta0_snowcompact_table ! snow viscosity coefficient [kg-s/m2] + real(kind=kind_noahmp) :: snliqmaxfrac_table ! maximum liquid water fraction in snow + real(kind=kind_noahmp) :: swemaxgla_table ! maximum swe allowed at glaciers (mm) + real(kind=kind_noahmp) :: wslmax_table ! maximum lake water storage (mm) + real(kind=kind_noahmp) :: rous_table ! specific yield [-] for Niu et al. 2007 groundwater scheme + real(kind=kind_noahmp) :: cmic_table ! microprore content (0.0-1.0), 0.0: close to free drainage + real(kind=kind_noahmp) :: snowden_max_table ! maximum fresh snowfall density (kg/m3) + real(kind=kind_noahmp) :: class_alb_ref_table ! reference snow albedo in class scheme + real(kind=kind_noahmp) :: class_sno_age_table ! snow aging e-folding time (s) in class albedo scheme + real(kind=kind_noahmp) :: class_alb_new_table ! fresh snow albedo in class scheme + real(kind=kind_noahmp) :: psiwlt_table ! soil metric potential for wilting point (m) + real(kind=kind_noahmp) :: z0soil_table ! bare-soil roughness length (m) (i.e., under the canopy) + real(kind=kind_noahmp) :: z0lake_table ! lake surface roughness length (m) + + ! irrigation parameters + integer :: irr_har_table ! number of days before harvest date to stop irrigation + real(kind=kind_noahmp) :: irr_frac_table ! irrigation fraction + real(kind=kind_noahmp) :: irr_lai_table ! minimum lai to trigger irrigation + real(kind=kind_noahmp) :: irr_mad_table ! management allowable deficit (0-1) + real(kind=kind_noahmp) :: filoss_table ! factor of flood irrigation loss + real(kind=kind_noahmp) :: sprir_rate_table ! mm/h, sprinkler irrigation rate + real(kind=kind_noahmp) :: micir_rate_table ! mm/h, micro irrigation rate + real(kind=kind_noahmp) :: firtfac_table ! flood application rate factor + real(kind=kind_noahmp) :: ir_rain_table ! maximum precipitation to stop irrigation trigger + + ! tile drainage parameters + integer :: drain_layer_opt_table ! tile drainage layer + integer , allocatable, dimension(:) :: td_depth_table ! tile drainage depth (layer number) from soil surface + real(kind=kind_noahmp), allocatable, dimension(:) :: tdsmc_fac_table ! tile drainage soil moisture factor + real(kind=kind_noahmp), allocatable, dimension(:) :: td_dc_table ! tile drainage coefficient [mm/d] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_dcoef_table ! tile drainage coefficient [mm/d] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_d_table ! depth to impervious layer from drain water level [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_adepth_table ! actual depth of impervious layer from land surface [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_radi_table ! effective radius of drain tubes [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_spac_table ! distance between two drain tubes or tiles [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: td_ddrain_table ! tile drainage depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: klat_fac_table ! hydraulic conductivity mutiplification factor + + ! crop parameters + integer :: default_crop_table ! default crop index + integer , allocatable, dimension(:) :: pltday_table ! planting date + integer , allocatable, dimension(:) :: hsday_table ! harvest date + real(kind=kind_noahmp), allocatable, dimension(:) :: plantpop_table ! plant density [per ha] - used? + real(kind=kind_noahmp), allocatable, dimension(:) :: irri_table ! irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + real(kind=kind_noahmp), allocatable, dimension(:) :: gddtbase_table ! base temperature for gdd accumulation [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: gddtcut_table ! upper temperature for gdd accumulation [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds1_table ! gdd from seeding to emergence + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds2_table ! gdd from seeding to initial vegetative + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds3_table ! gdd from seeding to post vegetative + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds4_table ! gdd from seeding to intial reproductive + real(kind=kind_noahmp), allocatable, dimension(:) :: gdds5_table ! gdd from seeding to pysical maturity + real(kind=kind_noahmp), allocatable, dimension(:) :: c3psni_table ! photosynthetic pathway: 0. = c4, 1. = c3 ! Zhe Zhang 2020-07-03 + real(kind=kind_noahmp), allocatable, dimension(:) :: kc25i_table ! co2 michaelis-menten constant at 25c (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: akci_table ! q10 for kc25 + real(kind=kind_noahmp), allocatable, dimension(:) :: ko25i_table ! o2 michaelis-menten constant at 25c (Pa) + real(kind=kind_noahmp), allocatable, dimension(:) :: akoi_table ! q10 for ko25 + real(kind=kind_noahmp), allocatable, dimension(:) :: vcmx25i_table ! maximum rate of carboxylation at 25c (umol CO2/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: avcmxi_table ! q10 for vcmx25 + real(kind=kind_noahmp), allocatable, dimension(:) :: bpi_table ! minimum leaf conductance (umol/m2/s) + real(kind=kind_noahmp), allocatable, dimension(:) :: mpi_table ! slope of conductance-to-photosynthesis relationship + real(kind=kind_noahmp), allocatable, dimension(:) :: qe25i_table ! quantum efficiency at 25c (umol CO2 / umol photon) + real(kind=kind_noahmp), allocatable, dimension(:) :: folnmxi_table ! foliage nitrogen concentration when f(n)=1 (%) + real(kind=kind_noahmp), allocatable, dimension(:) :: aref_table ! reference maximum CO2 assimulation rate + real(kind=kind_noahmp), allocatable, dimension(:) :: psnrf_table ! co2 assimulation reduction factor(0-1) (caused by non-modeled part, pest,weeds) + real(kind=kind_noahmp), allocatable, dimension(:) :: i2par_table ! fraction of incoming solar radiation to photosynthetically active radiation + real(kind=kind_noahmp), allocatable, dimension(:) :: tassim0_table ! minimum temperature for CO2 assimulation [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: tassim1_table ! co2 assimulation linearly increasing until temperature reaches t1 [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: tassim2_table ! co2 assmilation rate remain at aref until temperature reaches t2 [C] + real(kind=kind_noahmp), allocatable, dimension(:) :: k_table ! light extinction coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: epsi_table ! initial light use efficiency + real(kind=kind_noahmp), allocatable, dimension(:) :: q10mr_table ! q10 for maintainance respiration + real(kind=kind_noahmp), allocatable, dimension(:) :: lefreez_table ! characteristic t for leaf freezing [K] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dile_fc_table ! coeficient for temperature leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: dile_fw_table ! coeficient for water leaf stress death [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: fra_gr_table ! fraction of growth respiration + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lf_ovrc_table ! fraction of leaf turnover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: st_ovrc_table ! fraction of stem turnover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rt_ovrc_table ! fraction of root tunrover [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: lfmr25_table ! leaf maintenance respiration at 25C [umol CO2/m2/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: stmr25_table ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: rtmr25_table ! root maintenance respiration at 25C [umol CO2/kg bio/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: grainmr25_table ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfpt_table ! fraction of carbohydrate flux to leaf + real(kind=kind_noahmp), allocatable, dimension(:,:) :: stpt_table ! fraction of carbohydrate flux to stem + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rtpt_table ! fraction of carbohydrate flux to root + real(kind=kind_noahmp), allocatable, dimension(:,:) :: grainpt_table ! fraction of carbohydrate flux to grain + real(kind=kind_noahmp), allocatable, dimension(:,:) :: lfct_table ! fraction of carbohydrate translocation from leaf to grain + real(kind=kind_noahmp), allocatable, dimension(:,:) :: stct_table ! fraction of carbohydrate translocation from stem to grain + real(kind=kind_noahmp), allocatable, dimension(:,:) :: rtct_table ! fraction of carbohydrate translocation from root to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: bio2lai_table ! leaf area per living leaf biomass [m2/kg] + + ! soil parameters + integer :: slcats_table ! number of soil categories + real(kind=kind_noahmp), allocatable, dimension(:) :: bexp_table ! soil b parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: smcdry_table ! dry soil moisture threshold + real(kind=kind_noahmp), allocatable, dimension(:) :: smcmax_table ! porosity, saturated value of soil moisture (volumetric) + real(kind=kind_noahmp), allocatable, dimension(:) :: smcref_table ! reference soil moisture (field capacity) (volumetric) + real(kind=kind_noahmp), allocatable, dimension(:) :: psisat_table ! saturated soil matric potential + real(kind=kind_noahmp), allocatable, dimension(:) :: dksat_table ! saturated soil hydraulic conductivity + real(kind=kind_noahmp), allocatable, dimension(:) :: dwsat_table ! saturated soil hydraulic diffusivity + real(kind=kind_noahmp), allocatable, dimension(:) :: smcwlt_table ! wilting point soil moisture (volumetric) + real(kind=kind_noahmp), allocatable, dimension(:) :: quartz_table ! soil quartz content + real(kind=kind_noahmp), allocatable, dimension(:) :: bvic_table ! vic model infiltration parameter (-) for opt_run=6 + real(kind=kind_noahmp), allocatable, dimension(:) :: axaj_table ! xinanjiang: tension water distribution inflection parameter [-] for opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bxaj_table ! xinanjiang: tension water distribution shape parameter [-] for opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: xxaj_table ! xinanjiang: free water distribution shape parameter [-] for opt_run=7 + real(kind=kind_noahmp), allocatable, dimension(:) :: bdvic_table ! vic model infiltration parameter (-) + real(kind=kind_noahmp), allocatable, dimension(:) :: gdvic_table ! mean capilary drive (m) + real(kind=kind_noahmp), allocatable, dimension(:) :: bbvic_table ! heterogeniety parameter for dvic infiltration [-] + + ! general parameters + real(kind=kind_noahmp), allocatable, dimension(:) :: slope_table ! slope factor for soil drainage + real(kind=kind_noahmp) :: csoil_table ! Soil heat capacity [J m-3 K-1] + real(kind=kind_noahmp) :: refdk_table ! parameter in the surface runoff parameterization + real(kind=kind_noahmp) :: refkdt_table ! parameter in the surface runoff parameterization + real(kind=kind_noahmp) :: frzk_table ! frozen ground parameter + real(kind=kind_noahmp) :: zbot_table ! depth [m] of lower boundary soil temperature + real(kind=kind_noahmp) :: czil_table ! parameter used in the calculation of the roughness length for heat + + ! optional parameters + real(kind=kind_noahmp) :: sr2006_theta_1500t_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_c_TABLE ! orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_d_TABLE ! sand*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_e_TABLE ! clay*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500t_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_1500_a_TABLE ! theta_1500t coefficient + real(kind=kind_noahmp) :: sr2006_theta_1500_b_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_33t_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_c_TABLE ! orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_d_TABLE ! sand*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_e_TABLE ! clay*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_33t_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_33_a_TABLE ! theta_33t*theta_33t coefficient + real(kind=kind_noahmp) :: sr2006_theta_33_b_TABLE ! theta_33t coefficient + real(kind=kind_noahmp) :: sr2006_theta_33_c_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_s33t_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_c_TABLE ! orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_d_TABLE ! sand*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_e_TABLE ! clay*orgm coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33t_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_theta_s33_a_TABLE ! theta_s33t coefficient + real(kind=kind_noahmp) :: sr2006_theta_s33_b_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_psi_et_a_TABLE ! sand coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_b_TABLE ! clay coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_c_TABLE ! theta_s33 coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_d_TABLE ! sand*theta_s33 coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_e_TABLE ! clay*theta_s33 coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_f_TABLE ! sand*clay coefficient + real(kind=kind_noahmp) :: sr2006_psi_et_g_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_psi_e_a_TABLE ! psi_et*psi_et coefficient + real(kind=kind_noahmp) :: sr2006_psi_e_b_TABLE ! psi_et coefficient + real(kind=kind_noahmp) :: sr2006_psi_e_c_TABLE ! constant adjustment + real(kind=kind_noahmp) :: sr2006_smcmax_a_TABLE ! sand adjustment + real(kind=kind_noahmp) :: sr2006_smcmax_b_TABLE ! constant adjustment + + end type NoahmpIO_type + +end module NoahmpIOVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpInitMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpInitMainMod.F90 new file mode 100644 index 0000000000..2dfce6bf00 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpInitMainMod.F90 @@ -0,0 +1,253 @@ + module NoahmpInitMainMod + +!!! Module to initialize Noah-MP 2-D variables + + use Machine + use NoahmpIOVarType + use NoahmpSnowInitMod + + implicit none + + contains + + subroutine NoahmpInitMain(NoahmpIO) + +! ------------------------ Code history ------------------------------------- +! Original Noah-MP subroutine: NOAHMP_INIT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! --------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! local variables + integer :: its,ite + integer :: i,ns + integer :: errorflag + logical :: urbanpt_flag + real(kind=kind_noahmp) :: bexp, smcmax, psisat, fk + real(kind=kind_noahmp), parameter :: hlice = 3.335e5 + real(kind=kind_noahmp), parameter :: grav0 = 9.81 + real(kind=kind_noahmp), parameter :: t0 = 273.15 +! --------------------------------------------------------------------------- + +! only initialize for non-restart case: + if ( .not. NoahmpIO%restart_flag ) then + + its = NoahmpIO%its + ite = NoahmpIO%ite + + ! initialize physical snow height SNOWH + if ( .not. NoahmpIO%fndsnowh ) then + ! If no SNOWH do the following + print*, 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' + do i = its, ite + NoahmpIO%snowh(i) = NoahmpIO%snow(i)*0.005 ! snow in mm and snowh in m. + enddo + endif + + ! Check if snow/snowh are consistent and cap SWE at 2000mm + ! the Noah-MP code does it internally but if we don't do it here, problems ensue + do i = its, its + if ( NoahmpIO%snow(i) < 0.0 ) NoahmpIO%snow(i) = 0.0 + if ( NoahmpIO%snowh(i) < 0.0 ) NoahmpIO%snowh(i) = 0.0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%snowh(i) == 0.0) ) & + NoahmpIO%snowh(i) = NoahmpIO%snow(i) * 0.005 + if ( (NoahmpIO%snowh(i) > 0.0) .and. (NoahmpIO%snow(i) == 0.0) ) & + NoahmpIO%snow(i) = NoahmpIO%snowh(i) / 0.005 + if ( NoahmpIO%snow(i) > 2000.0 ) then + NoahmpIO%snowh(i) = NoahmpIO%snowh(i) * 2000.0 / NoahmpIO%snow(i) !snow in mm and snowh in m. + NoahmpIO%snow (i) = 2000.0 !cap snow at 2000 to maintain + !density. + endif + enddo + + ! check soil type: + errorflag = 0 + do i = its, ite + if ( NoahmpIO%isltyp(i) < 1 ) then + errorflag = 1 + write(*,*) "LSMINIT: OUT OF RANGE ISLTYP ",i,NoahmpIO%isltyp(i) + stop + endif + enddo + + ! initialize soil liquid water content SH2O: + do i = its , ite + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isice_table) .and. & + (NoahmpIO%xice(i) <= 0.0) ) then + do ns = 1, NoahmpIO%nsoil + NoahmpIO%smois(i,ns) = 1.0 ! glacier starts all frozen + NoahmpIO%sh2o(i,ns) = 0.0 + NoahmpIO%tslb(i,ns) = min(NoahmpIO%tslb(i,ns), 263.15) !set glacier temp to at most -10c + enddo + !NoahmpIO%tmn(i) = min(NoahmpIO%tmn(i), 263.15) !set deep temp to at most -10C + NoahmpIO%snow(i) = max(NoahmpIO%snow(i), 10.0) !set swe to at least 10mm + NoahmpIO%snowh(i) = NoahmpIO%snow(i) * 0.01 !snow in mm and snowh in m + else + bexp = NoahmpIO%bexp_table (NoahmpIO%isltyp(i)) + smcmax = NoahmpIO%smcmax_table(NoahmpIO%isltyp(i)) + psisat = NoahmpIO%psisat_table(NoahmpIO%isltyp(i)) + do ns = 1, NoahmpIO%nsoil + if ( NoahmpIO%smois(i,ns) > smcmax ) NoahmpIO%smois(i,ns) = smcmax + enddo + if ( (bexp > 0.0) .and. (smcmax > 0.0) .and. (psisat > 0.0) ) then + do ns = 1, NoahmpIO%nsoil + if ( NoahmpIO%tslb(i,ns) < 273.149 ) then + fk = (((hlice / (grav0*(-psisat))) * & + ((NoahmpIO%tslb(i,ns)-t0) / NoahmpIO%tslb(i,ns)))**(-1/bexp))*smcmax + fk = max(fk, 0.02) + NoahmpIO%sh2o(i,ns) = min(fk, NoahmpIO%smois(i,ns)) + else + NoahmpIO%sh2o(i,ns) = NoahmpIO%smois(i,ns) + endif + enddo + else + do ns = 1, NoahmpIO%nsoil + NoahmpIO%sh2o(i,ns) = NoahmpIO%smois(i,ns) + enddo + endif + endif + enddo + + ! initialize other quantities: + do i = its, ite + NoahmpIO%qtdrain(i) = 0.0 + NoahmpIO%tvxy(i) = NoahmpIO%tsk(i) + NoahmpIO%tgxy(i) = NoahmpIO%tsk(i) + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%tvxy(i) = t0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%tgxy(i) = t0 + + NoahmpIO%canwat(i) = 0.0 + NoahmpIO%canliqxy(i) = NoahmpIO%canwat(i) + NoahmpIO%canicexy(i) = 0.0 + NoahmpIO%eahxy(i) = 2000.0 + NoahmpIO%tahxy(i) = NoahmpIO%tsk(i) + NoahmpIO%t2mvxy(i) = NoahmpIO%tsk(i) + NoahmpIO%t2mbxy(i) = NoahmpIO%tsk(i) + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%tahxy(i) = t0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%t2mvxy(i) = t0 + if ( (NoahmpIO%snow(i) > 0.0) .and. (NoahmpIO%tsk(i) > t0) ) NoahmpIO%t2mbxy(i) = t0 + + NoahmpIO%cmxy(i) = 0.0 + NoahmpIO%chxy(i) = 0.0 + NoahmpIO%fwetxy(i) = 0.0 + NoahmpIO%sneqvoxy(i) = 0.0 + NoahmpIO%alboldxy(i) = 0.65 + NoahmpIO%qsnowxy(i) = 0.0 + NoahmpIO%qrainxy(i) = 0.0 + NoahmpIO%wslakexy(i) = 0.0 + + if ( NoahmpIO%iopt_runsub /= 5 ) then + NoahmpIO%waxy(i) = 4900.0 + NoahmpIO%wtxy(i) = NoahmpIO%waxy(i) + NoahmpIO%zwtxy(i) = (25.0 + 2.0) - NoahmpIO%waxy(i)/1000/0.2 + else + NoahmpIO%waxy(i) = 0.0 + NoahmpIO%wtxy(i) = 0.0 + endif + + urbanpt_flag = .false. + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isurban_table) .or. & + (NoahmpIO%ivgtyp(i) > NoahmpIO%urbtype_beg) ) then + urbanpt_flag = .true. + endif + + if ( (NoahmpIO%ivgtyp(i) == NoahmpIO%isbarren_table) .or. & + (NoahmpIO%ivgtyp(i) == NoahmpIO%isice_table) .or. & + ((NoahmpIO%sf_urban_physics == 0) .and. (urbanpt_flag .eqv. .true.)) .or. & + (NoahmpIO%ivgtyp(i) == NoahmpIO%iswater_table )) then + NoahmpIO%lai(i) = 0.0 + NoahmpIO%xsaixy(i) = 0.0 + NoahmpIO%lfmassxy(i) = 0.0 + NoahmpIO%stmassxy(i) = 0.0 + NoahmpIO%rtmassxy(i) = 0.0 + NoahmpIO%woodxy(i) = 0.0 + NoahmpIO%stblcpxy(i) = 0.0 + NoahmpIO%fastcpxy(i) = 0.0 + NoahmpIO%grainxy(i) = 1.0e-10 + NoahmpIO%gddxy(i) = 0 + NoahmpIO%cropcat(i) = 0 + else + if ( (NoahmpIO%lai(i) > 100) .or. (NoahmpIO%lai(i) < 0) ) NoahmpIO%lai(i) = 0.0 + NoahmpIO%lai(i) = max(NoahmpIO%lai(i), 0.05) !at least start with 0.05 for arbitrary initialization (v3.7) + NoahmpIO%xsaixy(i) = max(0.1*NoahmpIO%lai(i), 0.05) !mb: arbitrarily initialize sai using input lai (v3.7) + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) * 1000.0 / & + max(NoahmpIO%sla_table(NoahmpIO%ivgtyp(i)),1.0) !use lai to initialize (v3.7) + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) * 1000.0 / 3.0 !use sai to initialize (v3.7) + NoahmpIO%rtmassxy(i) = 500.0 !these are all arbitrary and probably should be + NoahmpIO%woodxy(i) = 500.0 !in the table or read from initialization + NoahmpIO%stblcpxy(i) = 1000.0 + NoahmpIO%fastcpxy(i) = 1000.0 + NoahmpIO%grainxy(i) = 1.0e-10 + NoahmpIO%gddxy(i) = 0 + + ! initialize crop for crop model: + if ( NoahmpIO%iopt_crop == 1 ) then + NoahmpIO%cropcat(i) = NoahmpIO%default_crop_table + if ( NoahmpIO%croptype(i,5) >= 0.5 ) then + NoahmpIO%rtmassxy(i) = 0.0 + NoahmpIO%woodxy (i) = 0.0 + if ( (NoahmpIO%croptype(i,1) > NoahmpIO%croptype(i,2)) .and. & + (NoahmpIO%croptype(i,1) > NoahmpIO%croptype(i,3)) .and. & + (NoahmpIO%croptype(i,1) > NoahmpIO%croptype(i,4)) ) then !choose corn + NoahmpIO%cropcat(i) = 1 + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) / 0.015 !initialize lfmass zhe zhang 2020-07-13 + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) / 0.003 + elseif ( (NoahmpIO%croptype(i,2) > NoahmpIO%croptype(i,1)) .and. & + (NoahmpIO%croptype(i,2) > NoahmpIO%croptype(i,3)) .and. & + (NoahmpIO%croptype(i,2) > NoahmpIO%croptype(i,4)) ) then!choose soybean + NoahmpIO%cropcat(i) = 2 + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) / 0.030 !initialize lfmass zhe zhang 2020-07-13 + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) / 0.003 + else + NoahmpIO%cropcat(i) = NoahmpIO%default_crop_table + NoahmpIO%lfmassxy(i) = NoahmpIO%lai(i) / 0.035 + NoahmpIO%stmassxy(i) = NoahmpIO%xsaixy(i) / 0.003 + endif + endif + endif + + ! Noah-MP irrigation scheme: + if ( (NoahmpIO%iopt_irr >= 1) .and. (NoahmpIO%iopt_irr <= 3) ) then + if ( (NoahmpIO%iopt_irrm == 0) .or. (NoahmpIO%iopt_irrm ==1) ) then ! sprinkler + NoahmpIO%irnumsi(i) = 0 + NoahmpIO%irwatsi(i) = 0.0 + NoahmpIO%ireloss(i) = 0.0 + NoahmpIO%irrsplh(i) = 0.0 + elseif ( (NoahmpIO%iopt_irrm == 0) .or. (NoahmpIO%iopt_irrm == 2) ) then ! micro or drip + NoahmpIO%irnummi(i) = 0 + NoahmpIO%irwatmi(i) = 0.0 + NoahmpIO%irmivol(i) = 0.0 + elseif ( (NoahmpIO%iopt_irrm == 0) .or. (NoahmpIO%iopt_irrm == 3) ) then ! flood + NoahmpIO%irnumfi(i) = 0 + NoahmpIO%irwatfi(i) = 0.0 + NoahmpIO%irfivol(i) = 0.0 + endif + endif + endif + enddo + + ! Given the soil layer thicknesses (in DZS), initialize the soil layer + ! depths from the surface: + NoahmpIO%zsoil(1) = -NoahmpIO%dzs(1) ! negative + do ns = 2, NoahmpIO%nsoil + NoahmpIO%zsoil(ns) = NoahmpIO%zsoil(ns-1) - NoahmpIO%dzs(ns) + enddo + + ! initialize noah-mp snow + call NoahmpSnowInitMain(NoahmpIO) + + !initialize arrays for groundwater dynamics iopt_runsub=5 + if ( NoahmpIO%iopt_runsub == 5 ) then + NoahmpIO%stepwtd = nint(NoahmpIO%wtddt * 60.0 / NoahmpIO%dtbl) + NoahmpIO%stepwtd = max(NoahmpIO%stepwtd,1) + endif + + endif ! NoahmpIO%restart_flag + + end subroutine NoahmpInitMain + + end module NoahmpInitMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadNamelistMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadNamelistMod.F90 new file mode 100644 index 0000000000..439e9161b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadNamelistMod.F90 @@ -0,0 +1,397 @@ +module NoahmpReadNamelistMod + +!!! Initialize Noah-MP namelist variables +!!! Namelist variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== read namelist values + + subroutine NoahmpReadNamelist(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +!--------------------------------------------------------------------- +! NAMELIST start +!--------------------------------------------------------------------- + + ! local namelist variables + + character(len=256) :: indir = '.' + integer :: ierr + integer :: NSOIL ! number of soil layers + integer :: forcing_timestep + integer :: noah_timestep + integer :: start_year + integer :: start_month + integer :: start_day + integer :: start_hour + integer :: start_min + character(len=256) :: outdir = "." + character(len=256) :: restart_filename_requested = " " + integer :: restart_frequency_hours + integer :: output_timestep + integer :: spinup_loops = 0 + integer :: sf_urban_physics = 0 + integer :: use_wudapt_lcz = 0 ! add for LCZ urban + integer :: num_urban_ndm = 2 + integer :: num_urban_ng = 10 + integer :: num_urban_nwr = 10 + integer :: num_urban_ngb = 10 + integer :: num_urban_nf = 10 + integer :: num_urban_nz = 18 + integer :: num_urban_nbui = 15 + integer :: num_urban_hi = 15 + integer :: num_urban_ngr = 10 ! = ngr_u in bep_bem.F + integer :: noahmp_output = 0 + real(kind=kind_noahmp) :: urban_atmosphere_thickness = 2.0 + real(kind=kind_noahmp) :: soil_timestep = 0.0 ! soil timestep (default=0: same as main noahmp timestep) + + ! derived urban dimensions + character(len=256) :: forcing_name_T = "T2D" + character(len=256) :: forcing_name_Q = "Q2D" + character(len=256) :: forcing_name_U = "U2D" + character(len=256) :: forcing_name_V = "V2D" + character(len=256) :: forcing_name_P = "PSFC" + character(len=256) :: forcing_name_LW = "LWDOWN" + character(len=256) :: forcing_name_SW = "SWDOWN" + character(len=256) :: forcing_name_PR = "RAINRATE" + character(len=256) :: forcing_name_SN = "" + integer :: dynamic_veg_option = 4 + integer :: canopy_stomatal_resistance_option = 1 + integer :: btr_option = 1 + integer :: surface_runoff_option = 3 + integer :: subsurface_runoff_option = 3 + integer :: surface_drag_option = 1 + integer :: supercooled_water_option = 1 + integer :: frozen_soil_option = 1 + integer :: radiative_transfer_option = 3 + integer :: snow_albedo_option = 1 + integer :: snow_thermal_conductivity = 1 + integer :: pcp_partition_option = 1 + integer :: tbot_option = 2 + integer :: temp_time_scheme_option = 1 + integer :: glacier_option = 1 + integer :: surface_resistance_option = 1 + integer :: soil_data_option = 1 + integer :: pedotransfer_option = 1 + integer :: crop_option = 0 + integer :: irrigation_option = 0 + integer :: irrigation_method = 0 + integer :: dvic_infiltration_option = 1 + integer :: tile_drainage_option = 0 + integer :: split_output_count = 1 + logical :: skip_first_output = .false. + integer :: khour = -9999 + integer :: kday = -9999 + real(kind=kind_noahmp) :: zlvl = 10. + character(len=256) :: hrldas_setup_file = " " + character(len=256) :: spatial_filename = " " + character(len=256) :: external_veg_filename_template = " " + character(len=256) :: external_lai_filename_template = " " + character(len=256) :: agdata_flnm = " " + character(len=256) :: tdinput_flnm = " " + integer, parameter :: MAX_SOIL_LEVELS = 10 ! maximum soil levels in namelist + real(kind=kind_noahmp), dimension(MAX_SOIL_LEVELS) :: soil_thick_input ! depth to soil interfaces from namelist [m] + + namelist / NOAHLSM_OFFLINE / & +#ifdef WRF_HYDRO + finemesh,finemesh_factor,forc_typ, snow_assim , GEO_STATIC_FLNM, HRLDAS_ini_typ, & +#endif + indir, nsoil, soil_thick_input, forcing_timestep, noah_timestep, soil_timestep, & + start_year, start_month, start_day, start_hour, start_min, & + outdir, skip_first_output, noahmp_output, & + restart_filename_requested, restart_frequency_hours, output_timestep, & + spinup_loops, & + forcing_name_T,forcing_name_Q,forcing_name_U,forcing_name_V,forcing_name_P, & + forcing_name_LW,forcing_name_SW,forcing_name_PR,forcing_name_SN, & + dynamic_veg_option, canopy_stomatal_resistance_option, & + btr_option, surface_drag_option, supercooled_water_option, & + frozen_soil_option, radiative_transfer_option, snow_albedo_option, & + snow_thermal_conductivity, surface_runoff_option, subsurface_runoff_option, & + pcp_partition_option, tbot_option, temp_time_scheme_option, & + glacier_option, surface_resistance_option, & + irrigation_option, irrigation_method, dvic_infiltration_option, & + tile_drainage_option,soil_data_option, pedotransfer_option, crop_option, & + sf_urban_physics,use_wudapt_lcz,num_urban_hi,urban_atmosphere_thickness, & + num_urban_ndm,num_urban_ng,num_urban_nwr ,num_urban_ngb , & + num_urban_nf ,num_urban_nz,num_urban_nbui,num_urban_ngr , & + split_output_count, & + khour, kday, zlvl, hrldas_setup_file, & + spatial_filename, agdata_flnm, tdinput_flnm, & + external_veg_filename_template, external_lai_filename_template + + + !--------------------------------------------------------------- + ! Initialize namelist variables to dummy values, so we can tell + ! if they have not been set properly. + !--------------------------------------------------------------- + if (.not. allocated(NoahmpIO%soil_thick_input)) allocate(NoahmpIO%soil_thick_input(1:MAX_SOIL_LEVELS)) + NoahmpIO%nsoil = undefined_int + NoahmpIO%soil_thick_input = undefined_real + NoahmpIO%DTBL = undefined_real + NoahmpIO%soiltstep = undefined_real + NoahmpIO%start_year = undefined_int + NoahmpIO%start_month = undefined_int + NoahmpIO%start_day = undefined_int + NoahmpIO%start_hour = undefined_int + NoahmpIO%start_min = undefined_int + NoahmpIO%khour = undefined_int + NoahmpIO%kday = undefined_int + NoahmpIO%zlvl = undefined_real + NoahmpIO%forcing_timestep = undefined_int + NoahmpIO%noah_timestep = undefined_int + NoahmpIO%output_timestep = undefined_int + NoahmpIO%restart_frequency_hours = undefined_int + NoahmpIO%spinup_loops = 0 + NoahmpIO%noahmp_output = 0 + + !--------------------------------------------------------------- + ! read namelist.input + !--------------------------------------------------------------- + + open(30, file="namelist.hrldas", form="FORMATTED") + read(30, NOAHLSM_OFFLINE, iostat=ierr) + if (ierr /= 0) then + write(*,'(/," ***** ERROR: Problem reading namelist NOAHLSM_OFFLINE",/)') + rewind(30) + read(30, NOAHLSM_OFFLINE) + stop " ***** ERROR: Problem reading namelist NOAHLSM_OFFLINE" + endif + close(30) + + NoahmpIO%DTBL = real(noah_timestep) + NoahmpIO%soiltstep = soil_timestep + NoahmpIO%NSOIL = nsoil + + !--------------------------------------------------------------------- + ! NAMELIST end + !--------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! NAMELIST check begin + !--------------------------------------------------------------------- + NoahmpIO%update_lai = .true. ! default: use LAI if present in forcing file + if(dynamic_veg_option == 1 .or. dynamic_veg_option == 2 .or. & + dynamic_veg_option == 3 .or. dynamic_veg_option == 4 .or. & + dynamic_veg_option == 5 .or. dynamic_veg_option == 6) & ! remove dveg=10 and add dveg=1,3,4 into the update_lai flag false condition + NoahmpIO%update_lai = .false. + + NoahmpIO%update_veg = .false. ! default: don't use VEGFRA if present in forcing file + if (dynamic_veg_option == 1 .or. dynamic_veg_option == 6 .or. dynamic_veg_option == 7) & + NoahmpIO%update_veg = .true. + + if (nsoil < 0) then + stop " ***** ERROR: NSOIL must be set in the namelist." + endif + + if ((khour < 0) .and. (kday < 0)) then + write(*, '(" ***** Namelist error: ************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** Either KHOUR or KDAY must be defined.")') + write(*, '(" ***** ")') + stop + else if (( khour < 0 ) .and. (kday > 0)) then + khour = kday * 24 + else if ((khour > 0) .and. (kday > 0)) then + write(*, '("Namelist warning: KHOUR and KDAY both defined.")') + else + ! all is well. KHOUR defined + endif + + if (forcing_timestep < 0) then + write(*, *) + write(*, '(" ***** Namelist error: *****************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** FORCING_TIMESTEP needs to be set greater than zero.")') + write(*, '(" ***** ")') + write(*, *) + stop + endif + + if (noah_timestep < 0) then + write(*, *) + write(*, '(" ***** Namelist error: *****************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** NOAH_TIMESTEP needs to be set greater than zero.")') + write(*, '(" ***** 900 seconds is recommended. ")') + write(*, '(" ***** ")') + write(*, *) + stop + endif + + ! + ! Check that OUTPUT_TIMESTEP fits into NOAH_TIMESTEP: + ! + if (output_timestep /= 0) then + if (mod(output_timestep, noah_timestep) > 0) then + write(*, *) + write(*, '(" ***** Namelist error: *********************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** OUTPUT_TIMESTEP should set to an integer multiple of NOAH_TIMESTEP.")') + write(*, '(" ***** OUTPUT_TIMESTEP = ", I12, " seconds")') output_timestep + write(*, '(" ***** NOAH_TIMESTEP = ", I12, " seconds")') noah_timestep + write(*, '(" ***** ")') + write(*, *) + stop + endif + endif + + ! + ! Check that RESTART_FREQUENCY_HOURS fits into NOAH_TIMESTEP: + ! + if (restart_frequency_hours /= 0) then + if (mod(restart_frequency_hours*3600, noah_timestep) > 0) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** RESTART_FREQUENCY_HOURS (converted to seconds) should set to an ")') + write(*, '(" ***** integer multiple of NOAH_TIMESTEP.")') + write(*, '(" ***** RESTART_FREQUENCY_HOURS = ", I12, " hours: ", I12, " seconds")') & + restart_frequency_hours, restart_frequency_hours*3600 + write(*, '(" ***** NOAH_TIMESTEP = ", I12, " seconds")') noah_timestep + write(*, '(" ***** ")') + write(*, *) + stop + endif + endif + + if (dynamic_veg_option == 2 .or. dynamic_veg_option == 5 .or. dynamic_veg_option == 6) then + if ( canopy_stomatal_resistance_option /= 1) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** CANOPY_STOMATAL_RESISTANCE_OPTION must be 1 when DYNAMIC_VEG_OPTION == 2/5/6")') + write(*, *) + stop + endif + endif + + if (soil_data_option == 4 .and. spatial_filename == " ") then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** SPATIAL_FILENAME must be provided when SOIL_DATA_OPTION == 4")') + write(*, *) + stop + endif + + if (sf_urban_physics == 2 .or. sf_urban_physics == 3) then + if ( urban_atmosphere_thickness <= 0.0) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** When running BEP/BEM, URBAN_ATMOSPHERE_LEVELS must contain at least 3 levels")') + write(*, *) + stop + endif + NoahmpIO%num_urban_atmosphere = int(zlvl/urban_atmosphere_thickness) + if (zlvl - NoahmpIO%num_urban_atmosphere*urban_atmosphere_thickness >= 0.5*urban_atmosphere_thickness) & + NoahmpIO%num_urban_atmosphere = NoahmpIO%num_urban_atmosphere + 1 + if ( NoahmpIO%num_urban_atmosphere <= 2) then + write(*, *) + write(*, '(" ***** Namelist error: ******************************************************")') + write(*, '(" ***** ")') + write(*, '(" ***** When running BEP/BEM, num_urban_atmosphere must contain at least 3 levels, ")') + write(*, '(" ***** decrease URBAN_ATMOSPHERE_THICKNESS")') + write(*, *) + stop + endif + endif + + !--------------------------------------------------------------------- + ! Transfer Namelist locals to input data structure + !--------------------------------------------------------------------- + ! physics option + NoahmpIO%IOPT_DVEG = dynamic_veg_option + NoahmpIO%IOPT_CRS = canopy_stomatal_resistance_option + NoahmpIO%IOPT_BTR = btr_option + NoahmpIO%IOPT_RUNSRF = surface_runoff_option + NoahmpIO%IOPT_RUNSUB = subsurface_runoff_option + NoahmpIO%IOPT_SFC = surface_drag_option + NoahmpIO%IOPT_FRZ = supercooled_water_option + NoahmpIO%IOPT_INF = frozen_soil_option + NoahmpIO%IOPT_RAD = radiative_transfer_option + NoahmpIO%IOPT_ALB = snow_albedo_option + NoahmpIO%IOPT_SNF = pcp_partition_option + NoahmpIO%IOPT_TKSNO = snow_thermal_conductivity + NoahmpIO%IOPT_TBOT = tbot_option + NoahmpIO%IOPT_STC = temp_time_scheme_option + NoahmpIO%IOPT_GLA = glacier_option + NoahmpIO%IOPT_RSF = surface_resistance_option + NoahmpIO%IOPT_SOIL = soil_data_option + NoahmpIO%IOPT_PEDO = pedotransfer_option + NoahmpIO%IOPT_CROP = crop_option + NoahmpIO%IOPT_IRR = irrigation_option + NoahmpIO%IOPT_IRRM = irrigation_method + NoahmpIO%IOPT_INFDV = dvic_infiltration_option + NoahmpIO%IOPT_TDRN = tile_drainage_option + ! basic model setup variables + NoahmpIO%indir = indir + NoahmpIO%forcing_timestep = forcing_timestep + NoahmpIO%noah_timestep = noah_timestep + NoahmpIO%start_year = start_year + NoahmpIO%start_month = start_month + NoahmpIO%start_day = start_day + NoahmpIO%start_hour = start_hour + NoahmpIO%start_min = start_min + NoahmpIO%outdir = outdir + NoahmpIO%noahmp_output = noahmp_output + NoahmpIO%restart_filename_requested = restart_filename_requested + NoahmpIO%restart_frequency_hours = restart_frequency_hours + NoahmpIO%output_timestep = output_timestep + NoahmpIO%spinup_loops = spinup_loops + NoahmpIO%sf_urban_physics = sf_urban_physics + NoahmpIO%use_wudapt_lcz = use_wudapt_lcz + NoahmpIO%num_urban_ndm = num_urban_ndm + NoahmpIO%num_urban_ng = num_urban_ng + NoahmpIO%num_urban_nwr = num_urban_nwr + NoahmpIO%num_urban_ngb = num_urban_ngb + NoahmpIO%num_urban_nf = num_urban_nf + NoahmpIO%num_urban_nz = num_urban_nz + NoahmpIO%num_urban_nbui = num_urban_nbui + NoahmpIO%num_urban_hi = num_urban_hi + NoahmpIO%urban_atmosphere_thickness = urban_atmosphere_thickness + NoahmpIO%num_urban_ngr = num_urban_ngr + NoahmpIO%forcing_name_T = forcing_name_T + NoahmpIO%forcing_name_Q = forcing_name_Q + NoahmpIO%forcing_name_U = forcing_name_U + NoahmpIO%forcing_name_V = forcing_name_V + NoahmpIO%forcing_name_P = forcing_name_P + NoahmpIO%forcing_name_LW = forcing_name_LW + NoahmpIO%forcing_name_SW = forcing_name_SW + NoahmpIO%forcing_name_PR = forcing_name_PR + NoahmpIO%forcing_name_SN = forcing_name_SN + NoahmpIO%split_output_count = split_output_count + NoahmpIO%skip_first_output = skip_first_output + NoahmpIO%khour = khour + NoahmpIO%kday = kday + NoahmpIO%zlvl = zlvl + NoahmpIO%hrldas_setup_file = hrldas_setup_file + NoahmpIO%spatial_filename = spatial_filename + NoahmpIO%external_veg_filename_template = external_veg_filename_template + NoahmpIO%external_lai_filename_template = external_lai_filename_template + NoahmpIO%agdata_flnm = agdata_flnm + NoahmpIO%tdinput_flnm = tdinput_flnm + NoahmpIO%MAX_SOIL_LEVELS = MAX_SOIL_LEVELS + NoahmpIO%soil_thick_input = soil_thick_input + +!--------------------------------------------------------------------- +! NAMELIST check end +!--------------------------------------------------------------------- + + end subroutine NoahmpReadNamelist + +end module NoahmpReadNamelistMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadTableMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadTableMod.F90 new file mode 100644 index 0000000000..eb01ceb2fa --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpReadTableMod.F90 @@ -0,0 +1,1182 @@ +module NoahmpReadTableMod + +!!! Initialize Noah-MP look-up table variables +!!! Table variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + + implicit none + +contains + +!=== read Noahmp Table values + + subroutine NoahmpReadTable(NoahmpIO) + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + + !------------------------------------------------------- + !=== define key dimensional variables + !------------------------------------------------------- + integer, parameter :: MVT = 27 ! number of vegetation types + integer, parameter :: MBAND = 2 ! number of radiation bands + integer, parameter :: MSC = 8 ! number of soil texture + integer, parameter :: MAX_SOILTYP = 30 ! max number of soil types + integer, parameter :: NCROP = 5 ! number of crop types + integer, parameter :: NSTAGE = 8 ! number of crop growth stages + integer, parameter :: NUM_SLOPE = 9 ! number of slope + + !------------------------------------------------------- + !=== define local variables to store NoahmpTable values + !------------------------------------------------------- + + ! vegetation parameters + character(len=256) :: DATASET_IDENTIFIER + character(len=256) :: VEG_DATASET_DESCRIPTION + logical :: file_named + integer :: ierr, IK, IM + integer :: NVEG, ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, URBTYPE_beg + integer :: LCZ_1, LCZ_2, LCZ_3, LCZ_4, LCZ_5, LCZ_6, LCZ_7, LCZ_8, LCZ_9, LCZ_10, LCZ_11 + real(kind=kind_noahmp), dimension(MVT) :: SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN, SAI_JUL, SAI_AUG, & + SAI_SEP, SAI_OCT, SAI_NOV, SAI_DEC, LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, & + LAI_MAY, LAI_JUN, LAI_JUL, LAI_AUG, LAI_SEP, LAI_OCT, LAI_NOV, LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR,& + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, & + AKC, KO25, AKO, AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25, SLA, FRAGR, TMIN, & + VCMX25, TDLEF, BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + NROOT, RGL, RS, HS, TOPT, RSMAX, RTOVRC, RSWOODC, BF, WSTRC, LAIMIN, CBIOM, & + XSAMIN + namelist / noahmp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + namelist / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, URBTYPE_beg, & + LCZ_1, LCZ_2, LCZ_3, LCZ_4, LCZ_5, LCZ_6, LCZ_7, LCZ_8, LCZ_9, LCZ_10, LCZ_11, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, & + AKC, KO25, AKO, AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25, SLA, FRAGR, TMIN, & + VCMX25, TDLEF, BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + NROOT, RGL, RS, HS, TOPT, RSMAX, RTOVRC, RSWOODC, BF, WSTRC, LAIMIN, CBIOM, & + XSAMIN, SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, & + SAI_JUN, SAI_JUL, SAI_AUG, SAI_SEP, SAI_OCT, SAI_NOV, SAI_DEC, LAI_JAN, & + LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN, LAI_JUL, LAI_AUG, LAI_SEP, & + LAI_OCT, LAI_NOV, LAI_DEC, RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, & + TAUL_NIR, TAUS_VIS, TAUS_NIR + namelist / noahmp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + namelist / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, URBTYPE_beg, & + LCZ_1, LCZ_2, LCZ_3, LCZ_4, LCZ_5, LCZ_6, LCZ_7, LCZ_8, LCZ_9, LCZ_10, LCZ_11, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, SCFFAC, XL, CWPVT, C3PSN, KC25, & + AKC, KO25, AKO, AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25, SLA, FRAGR, TMIN, & + VCMX25, TDLEF, BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, & + NROOT, RGL, RS, HS, TOPT, RSMAX, RTOVRC, RSWOODC, BF, WSTRC, LAIMIN, CBIOM, & + XSAMIN, SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, & + SAI_JUN, SAI_JUL, SAI_AUG, SAI_SEP, SAI_OCT, SAI_NOV, SAI_DEC, LAI_JAN, & + LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN, LAI_JUL, LAI_AUG, LAI_SEP, & + LAI_OCT, LAI_NOV, LAI_DEC, RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, & + TAUL_NIR, TAUS_VIS, TAUS_NIR + + ! soil parameters + character(len=256) :: message + character(len=10) :: SLTYPE + integer :: SLCATS + real(kind=kind_noahmp), dimension(MAX_SOILTYP) :: BB, DRYSMC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + BVIC, AXAJ, BXAJ, XXAJ, BDVIC, BBVIC, GDVIC, HC + namelist / noahmp_stas_soil_categories / SLTYPE, SLCATS + namelist / noahmp_soil_stas_parameters / BB, DRYSMC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + BVIC, AXAJ, BXAJ, XXAJ, BDVIC, BBVIC, GDVIC + namelist / noahmp_soil_stas_ruc_parameters / BB, DRYSMC, HC, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + BVIC, AXAJ, BXAJ, XXAJ, BDVIC, BBVIC, GDVIC + + ! general parameters + real(kind=kind_noahmp) :: CSOIL_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, CZIL_DATA + real(kind=kind_noahmp), dimension(NUM_SLOPE) :: SLOPE_DATA + namelist / noahmp_general_parameters / SLOPE_DATA, CSOIL_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, & + CZIL_DATA + + ! radiation parameters + real(kind=kind_noahmp) :: BETADS, BETAIS, EICE + real(kind=kind_noahmp), dimension(MBAND) :: ALBICE, ALBLAK, OMEGAS + real(kind=kind_noahmp), dimension(2) :: EG + real(kind=kind_noahmp), dimension(MSC) :: ALBSAT_VIS, ALBSAT_NIR, ALBDRY_VIS, ALBDRY_NIR + namelist / noahmp_rad_parameters / ALBSAT_VIS, ALBSAT_NIR, ALBDRY_VIS, ALBDRY_NIR, ALBICE, ALBLAK, OMEGAS, & + BETADS, BETAIS, EG, EICE + + ! global parameters + real(kind=kind_noahmp) :: CO2, O2, TIMEAN, FSATMX, Z0SNO, SSI, SNOW_RET_FAC ,SNOW_EMIS, SWEMX, TAU0, & + GRAIN_GROWTH, EXTRA_GROWTH, DIRT_SOOT, BATS_COSZ, BATS_VIS_NEW, & + BATS_NIR_NEW, BATS_VIS_AGE, BATS_NIR_AGE, BATS_VIS_DIR, BATS_NIR_DIR, & + RSURF_SNOW, RSURF_EXP, C2_SNOWCOMPACT, C3_SNOWCOMPACT, C4_SNOWCOMPACT, & + C5_SNOWCOMPACT, DM_SNOWCOMPACT, ETA0_SNOWCOMPACT, SNLIQMAXFRAC, SWEMAXGLA, & + WSLMAX, ROUS, CMIC, SNOWDEN_MAX, CLASS_ALB_REF, CLASS_SNO_AGE, CLASS_ALB_NEW,& + PSIWLT, Z0SOIL, Z0LAKE + namelist / noahmp_global_parameters / CO2, O2, TIMEAN, FSATMX, Z0SNO, SSI, SNOW_RET_FAC ,SNOW_EMIS, SWEMX, TAU0, & + GRAIN_GROWTH, EXTRA_GROWTH, DIRT_SOOT, BATS_COSZ, BATS_VIS_NEW, & + BATS_NIR_NEW, BATS_VIS_AGE, BATS_NIR_AGE, BATS_VIS_DIR, BATS_NIR_DIR, & + RSURF_SNOW, RSURF_EXP, C2_SNOWCOMPACT, C3_SNOWCOMPACT, C4_SNOWCOMPACT, & + C5_SNOWCOMPACT, DM_SNOWCOMPACT, ETA0_SNOWCOMPACT, SNLIQMAXFRAC, SWEMAXGLA, & + WSLMAX, ROUS, CMIC, SNOWDEN_MAX, CLASS_ALB_REF, CLASS_SNO_AGE, CLASS_ALB_NEW,& + PSIWLT, Z0SOIL, Z0LAKE + + ! irrigation parameters + integer :: IRR_HAR + real(kind=kind_noahmp) :: IRR_FRAC, IRR_LAI, IRR_MAD, FILOSS, SPRIR_RATE, MICIR_RATE, FIRTFAC, IR_RAIN + namelist / noahmp_irrigation_parameters / IRR_FRAC, IRR_HAR, IRR_LAI, IRR_MAD, FILOSS, SPRIR_RATE, MICIR_RATE, FIRTFAC,& + IR_RAIN + + ! crop parameters + integer :: DEFAULT_CROP + integer , dimension(NCROP) :: PLTDAY, HSDAY + real(kind=kind_noahmp), dimension(NCROP) :: PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2, GDDS3, GDDS4, GDDS5, C3PSNI,& + KC25I, AKCI, KO25I, AKOI, AVCMXI, VCMX25I, BPI, MPI, FOLNMXI, QE25I, AREF, & + PSNRF, I2PAR, TASSIM0, TASSIM1, TASSIM2, K, EPSI, Q10MR, LEFREEZ, & + DILE_FC_S1, DILE_FC_S2, DILE_FC_S3, DILE_FC_S4, DILE_FC_S5, DILE_FC_S6, & + DILE_FC_S7, DILE_FC_S8, DILE_FW_S1, DILE_FW_S2, DILE_FW_S3, DILE_FW_S4, & + DILE_FW_S5, DILE_FW_S6, DILE_FW_S7, DILE_FW_S8, FRA_GR, LF_OVRC_S1, & + LF_OVRC_S2, LF_OVRC_S3, LF_OVRC_S4, LF_OVRC_S5, LF_OVRC_S6, LF_OVRC_S7, & + LF_OVRC_S8, ST_OVRC_S1, ST_OVRC_S2, ST_OVRC_S3, ST_OVRC_S4, ST_OVRC_S5, & + ST_OVRC_S6, ST_OVRC_S7, ST_OVRC_S8, RT_OVRC_S1, RT_OVRC_S2, RT_OVRC_S3, & + RT_OVRC_S4, RT_OVRC_S5, RT_OVRC_S6, RT_OVRC_S7, RT_OVRC_S8, LFMR25, STMR25, & + RTMR25, GRAINMR25, LFPT_S1, LFPT_S2, LFPT_S3, LFPT_S4, LFPT_S5, LFPT_S6, & + LFPT_S7, LFPT_S8, STPT_S1, STPT_S2, STPT_S3, STPT_S4, STPT_S5, STPT_S6, & + STPT_S7, STPT_S8, RTPT_S1, RTPT_S2, RTPT_S3, RTPT_S4, RTPT_S5, RTPT_S6, & + RTPT_S7, RTPT_S8, GRAINPT_S1, GRAINPT_S2, GRAINPT_S3, GRAINPT_S4, GRAINPT_S5,& + GRAINPT_S6, GRAINPT_S7, GRAINPT_S8, LFCT_S1, LFCT_S2, LFCT_S3, LFCT_S4, & + LFCT_S5, LFCT_S6, LFCT_S7, LFCT_S8, STCT_S1, STCT_S2, STCT_S3, STCT_S4, & + STCT_S5, STCT_S6, STCT_S7, STCT_S8, RTCT_S1, RTCT_S2, RTCT_S3, RTCT_S4, & + RTCT_S5, RTCT_S6, RTCT_S7, RTCT_S8, BIO2LAI + namelist / noahmp_crop_parameters / DEFAULT_CROP, PLTDAY, HSDAY, PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2,& + GDDS3, GDDS4, GDDS5, C3PSNI, KC25I, AKCI, KO25I, AKOI, AVCMXI, VCMX25I, BPI, & + MPI, FOLNMXI, QE25I, AREF, PSNRF, I2PAR, TASSIM0, TASSIM1, TASSIM2, K, & + EPSI,Q10MR, LEFREEZ, DILE_FC_S1, DILE_FC_S2, DILE_FC_S3, DILE_FC_S4, & + DILE_FC_S5, DILE_FC_S6, DILE_FC_S7, DILE_FC_S8, DILE_FW_S1, DILE_FW_S2, & + DILE_FW_S3, DILE_FW_S4, DILE_FW_S5, DILE_FW_S6, DILE_FW_S7, DILE_FW_S8, & + FRA_GR, LF_OVRC_S1, LF_OVRC_S2, LF_OVRC_S3, LF_OVRC_S4, LF_OVRC_S5, & + LF_OVRC_S6, LF_OVRC_S7, LF_OVRC_S8, ST_OVRC_S1, ST_OVRC_S2, ST_OVRC_S3, & + ST_OVRC_S4, ST_OVRC_S5, ST_OVRC_S6, ST_OVRC_S7, ST_OVRC_S8, RT_OVRC_S1, & + RT_OVRC_S2, RT_OVRC_S3, RT_OVRC_S4, RT_OVRC_S5, RT_OVRC_S6, RT_OVRC_S7, & + RT_OVRC_S8, LFMR25, STMR25, RTMR25, GRAINMR25, LFPT_S1, LFPT_S2, LFPT_S3, & + LFPT_S4, LFPT_S5, LFPT_S6, LFPT_S7, LFPT_S8, STPT_S1, STPT_S2, STPT_S3, & + STPT_S4, STPT_S5, STPT_S6, STPT_S7, STPT_S8, RTPT_S1, RTPT_S2, RTPT_S3, & + RTPT_S4, RTPT_S5, RTPT_S6, RTPT_S7, RTPT_S8, GRAINPT_S1, GRAINPT_S2, & + GRAINPT_S3, GRAINPT_S4, GRAINPT_S5, GRAINPT_S6, GRAINPT_S7, GRAINPT_S8, & + LFCT_S1, LFCT_S2, LFCT_S3, LFCT_S4, LFCT_S5, LFCT_S6, LFCT_S7, LFCT_S8, & + STCT_S1, STCT_S2, STCT_S3, STCT_S4, STCT_S5, STCT_S6, STCT_S7, STCT_S8, & + RTCT_S1, RTCT_S2, RTCT_S3, RTCT_S4, RTCT_S5, RTCT_S6, RTCT_S7, RTCT_S8, & + BIO2LAI + + ! tile drainage parameters + integer :: NSOILTYPE, DRAIN_LAYER_OPT + integer , dimension(MAX_SOILTYP) :: TD_DEPTH + real(kind=kind_noahmp), dimension(MAX_SOILTYP) :: TDSMC_FAC, TD_DC, TD_DCOEF, TD_D, TD_ADEPTH, TD_RADI, TD_SPAC, & + TD_DDRAIN, KLAT_FAC + namelist / noahmp_tiledrain_parameters / NSOILTYPE, DRAIN_LAYER_OPT, TDSMC_FAC, TD_DEPTH, TD_DC, TD_DCOEF, TD_D,& + TD_ADEPTH, TD_RADI, TD_SPAC, TD_DDRAIN, KLAT_FAC + + ! optional parameters + real(kind=kind_noahmp) :: sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g, sr2006_theta_1500_a , sr2006_theta_1500_b, & + sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & + sr2006_theta_33t_d, sr2006_theta_33t_e, sr2006_theta_33t_f, & + sr2006_theta_33t_g, sr2006_theta_33_a, sr2006_theta_33_b, & + sr2006_theta_33_c, sr2006_theta_s33t_a, sr2006_theta_s33t_b, & + sr2006_theta_s33t_c, sr2006_theta_s33t_d, sr2006_theta_s33t_e, & + sr2006_theta_s33t_f, sr2006_theta_s33t_g, sr2006_theta_s33_a, & + sr2006_theta_s33_b, sr2006_psi_et_a, sr2006_psi_et_b, sr2006_psi_et_c, & + sr2006_psi_et_d, sr2006_psi_et_e, sr2006_psi_et_f, sr2006_psi_et_g, & + sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & + sr2006_smcmax_b + namelist / noahmp_optional_parameters / sr2006_theta_1500t_a, sr2006_theta_1500t_b, sr2006_theta_1500t_c, & + sr2006_theta_1500t_d, sr2006_theta_1500t_e, sr2006_theta_1500t_f, & + sr2006_theta_1500t_g, sr2006_theta_1500_a, sr2006_theta_1500_b, & + sr2006_theta_33t_a, sr2006_theta_33t_b, sr2006_theta_33t_c, & + sr2006_theta_33t_d, sr2006_theta_33t_e, sr2006_theta_33t_f, & + sr2006_theta_33t_g, sr2006_theta_33_a, sr2006_theta_33_b, & + sr2006_theta_33_c, sr2006_theta_s33t_a, sr2006_theta_s33t_b, & + sr2006_theta_s33t_c, sr2006_theta_s33t_d, sr2006_theta_s33t_e, & + sr2006_theta_s33t_f, sr2006_theta_s33t_g, sr2006_theta_s33_a, & + sr2006_theta_s33_b, sr2006_psi_et_a, sr2006_psi_et_b, sr2006_psi_et_c, & + sr2006_psi_et_d, sr2006_psi_et_e, sr2006_psi_et_f, sr2006_psi_et_g, & + sr2006_psi_e_a, sr2006_psi_e_b, sr2006_psi_e_c, sr2006_smcmax_a, & + sr2006_smcmax_b + + !-------------------------------------------------- + !=== allocate multi-dim input table variables + !-------------------------------------------------- + + ! vegetation parameters + if ( .not. allocated (NoahmpIO%CH2OP_TABLE) ) allocate( NoahmpIO%CH2OP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DLEAF_TABLE) ) allocate( NoahmpIO%DLEAF_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%Z0MVT_TABLE) ) allocate( NoahmpIO%Z0MVT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%HVT_TABLE) ) allocate( NoahmpIO%HVT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%HVB_TABLE) ) allocate( NoahmpIO%HVB_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DEN_TABLE) ) allocate( NoahmpIO%DEN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RC_TABLE) ) allocate( NoahmpIO%RC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%MFSNO_TABLE) ) allocate( NoahmpIO%MFSNO_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%SCFFAC_TABLE) ) allocate( NoahmpIO%SCFFAC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%CBIOM_TABLE) ) allocate( NoahmpIO%CBIOM_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%SAIM_TABLE) ) allocate( NoahmpIO%SAIM_TABLE (MVT,12) ) + if ( .not. allocated (NoahmpIO%LAIM_TABLE) ) allocate( NoahmpIO%LAIM_TABLE (MVT,12) ) + if ( .not. allocated (NoahmpIO%SLA_TABLE) ) allocate( NoahmpIO%SLA_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DILEFC_TABLE) ) allocate( NoahmpIO%DILEFC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%DILEFW_TABLE) ) allocate( NoahmpIO%DILEFW_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%FRAGR_TABLE) ) allocate( NoahmpIO%FRAGR_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%LTOVRC_TABLE) ) allocate( NoahmpIO%LTOVRC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%C3PSN_TABLE) ) allocate( NoahmpIO%C3PSN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%KC25_TABLE) ) allocate( NoahmpIO%KC25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AKC_TABLE) ) allocate( NoahmpIO%AKC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%KO25_TABLE) ) allocate( NoahmpIO%KO25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AKO_TABLE) ) allocate( NoahmpIO%AKO_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%VCMX25_TABLE) ) allocate( NoahmpIO%VCMX25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AVCMX_TABLE) ) allocate( NoahmpIO%AVCMX_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%BP_TABLE) ) allocate( NoahmpIO%BP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%MP_TABLE) ) allocate( NoahmpIO%MP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%QE25_TABLE) ) allocate( NoahmpIO%QE25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%AQE_TABLE) ) allocate( NoahmpIO%AQE_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RMF25_TABLE) ) allocate( NoahmpIO%RMF25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RMS25_TABLE) ) allocate( NoahmpIO%RMS25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RMR25_TABLE) ) allocate( NoahmpIO%RMR25_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%ARM_TABLE) ) allocate( NoahmpIO%ARM_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%FOLNMX_TABLE) ) allocate( NoahmpIO%FOLNMX_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%TMIN_TABLE) ) allocate( NoahmpIO%TMIN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%XL_TABLE) ) allocate( NoahmpIO%XL_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RHOL_TABLE) ) allocate( NoahmpIO%RHOL_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%RHOS_TABLE) ) allocate( NoahmpIO%RHOS_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%TAUL_TABLE) ) allocate( NoahmpIO%TAUL_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%TAUS_TABLE) ) allocate( NoahmpIO%TAUS_TABLE (MVT,MBAND) ) + if ( .not. allocated (NoahmpIO%MRP_TABLE) ) allocate( NoahmpIO%MRP_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%CWPVT_TABLE) ) allocate( NoahmpIO%CWPVT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%WRRAT_TABLE) ) allocate( NoahmpIO%WRRAT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%WDPOOL_TABLE) ) allocate( NoahmpIO%WDPOOL_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%TDLEF_TABLE) ) allocate( NoahmpIO%TDLEF_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%NROOT_TABLE) ) allocate( NoahmpIO%NROOT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RGL_TABLE) ) allocate( NoahmpIO%RGL_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RS_TABLE) ) allocate( NoahmpIO%RS_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%HS_TABLE) ) allocate( NoahmpIO%HS_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%TOPT_TABLE) ) allocate( NoahmpIO%TOPT_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RSMAX_TABLE) ) allocate( NoahmpIO%RSMAX_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RTOVRC_TABLE) ) allocate( NoahmpIO%RTOVRC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%RSWOODC_TABLE)) allocate( NoahmpIO%RSWOODC_TABLE(MVT) ) + if ( .not. allocated (NoahmpIO%BF_TABLE) ) allocate( NoahmpIO%BF_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%WSTRC_TABLE) ) allocate( NoahmpIO%WSTRC_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%LAIMIN_TABLE) ) allocate( NoahmpIO%LAIMIN_TABLE (MVT) ) + if ( .not. allocated (NoahmpIO%XSAMIN_TABLE) ) allocate( NoahmpIO%XSAMIN_TABLE (MVT) ) + + ! soil parameters + if ( .not. allocated (NoahmpIO%BEXP_TABLE) ) allocate( NoahmpIO%BEXP_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCDRY_TABLE) ) allocate( NoahmpIO%SMCDRY_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCMAX_TABLE) ) allocate( NoahmpIO%SMCMAX_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCREF_TABLE) ) allocate( NoahmpIO%SMCREF_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%PSISAT_TABLE) ) allocate( NoahmpIO%PSISAT_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%DKSAT_TABLE) ) allocate( NoahmpIO%DKSAT_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%DWSAT_TABLE) ) allocate( NoahmpIO%DWSAT_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%SMCWLT_TABLE) ) allocate( NoahmpIO%SMCWLT_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%QUARTZ_TABLE) ) allocate( NoahmpIO%QUARTZ_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BVIC_TABLE) ) allocate( NoahmpIO%BVIC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%AXAJ_TABLE) ) allocate( NoahmpIO%AXAJ_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BXAJ_TABLE) ) allocate( NoahmpIO%BXAJ_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%XXAJ_TABLE) ) allocate( NoahmpIO%XXAJ_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BDVIC_TABLE) ) allocate( NoahmpIO%BDVIC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%GDVIC_TABLE) ) allocate( NoahmpIO%GDVIC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%BBVIC_TABLE) ) allocate( NoahmpIO%BBVIC_TABLE (MAX_SOILTYP) ) + + ! general parameters + if ( .not. allocated (NoahmpIO%SLOPE_TABLE) ) allocate( NoahmpIO%SLOPE_TABLE(NUM_SLOPE) ) + + ! radiation parameters + if ( .not. allocated (NoahmpIO%ALBSAT_TABLE) ) allocate( NoahmpIO%ALBSAT_TABLE(MSC,MBAND) ) + if ( .not. allocated (NoahmpIO%ALBDRY_TABLE) ) allocate( NoahmpIO%ALBDRY_TABLE(MSC,MBAND) ) + if ( .not. allocated (NoahmpIO%ALBICE_TABLE) ) allocate( NoahmpIO%ALBICE_TABLE(MBAND) ) + if ( .not. allocated (NoahmpIO%ALBLAK_TABLE) ) allocate( NoahmpIO%ALBLAK_TABLE(MBAND) ) + if ( .not. allocated (NoahmpIO%OMEGAS_TABLE) ) allocate( NoahmpIO%OMEGAS_TABLE(MBAND) ) + if ( .not. allocated (NoahmpIO%EG_TABLE) ) allocate( NoahmpIO%EG_TABLE(2) ) + + ! tile drainage parameters + if ( .not. allocated (NoahmpIO%TDSMC_FAC_TABLE) ) allocate( NoahmpIO%TDSMC_FAC_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DC_TABLE) ) allocate( NoahmpIO%TD_DC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DEPTH_TABLE) ) allocate( NoahmpIO%TD_DEPTH_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DCOEF_TABLE) ) allocate( NoahmpIO%TD_DCOEF_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_D_TABLE) ) allocate( NoahmpIO%TD_D_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_ADEPTH_TABLE) ) allocate( NoahmpIO%TD_ADEPTH_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_RADI_TABLE) ) allocate( NoahmpIO%TD_RADI_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_SPAC_TABLE) ) allocate( NoahmpIO%TD_SPAC_TABLE (MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%TD_DDRAIN_TABLE) ) allocate( NoahmpIO%TD_DDRAIN_TABLE(MAX_SOILTYP) ) + if ( .not. allocated (NoahmpIO%KLAT_FAC_TABLE) ) allocate( NoahmpIO%KLAT_FAC_TABLE (MAX_SOILTYP) ) + + ! crop parameters + if ( .not. allocated (NoahmpIO%PLTDAY_TABLE) ) allocate( NoahmpIO%PLTDAY_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%HSDAY_TABLE) ) allocate( NoahmpIO%HSDAY_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%PLANTPOP_TABLE) ) allocate( NoahmpIO%PLANTPOP_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%IRRI_TABLE) ) allocate( NoahmpIO%IRRI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDTBASE_TABLE) ) allocate( NoahmpIO%GDDTBASE_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDTCUT_TABLE) ) allocate( NoahmpIO%GDDTCUT_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS1_TABLE) ) allocate( NoahmpIO%GDDS1_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS2_TABLE) ) allocate( NoahmpIO%GDDS2_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS3_TABLE) ) allocate( NoahmpIO%GDDS3_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS4_TABLE) ) allocate( NoahmpIO%GDDS4_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GDDS5_TABLE) ) allocate( NoahmpIO%GDDS5_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%C3PSNI_TABLE) ) allocate( NoahmpIO%C3PSNI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%KC25I_TABLE) ) allocate( NoahmpIO%KC25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AKCI_TABLE) ) allocate( NoahmpIO%AKCI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%KO25I_TABLE) ) allocate( NoahmpIO%KO25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AKOI_TABLE) ) allocate( NoahmpIO%AKOI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%VCMX25I_TABLE) ) allocate( NoahmpIO%VCMX25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AVCMXI_TABLE) ) allocate( NoahmpIO%AVCMXI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%BPI_TABLE) ) allocate( NoahmpIO%BPI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%MPI_TABLE) ) allocate( NoahmpIO%MPI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%QE25I_TABLE) ) allocate( NoahmpIO%QE25I_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%FOLNMXI_TABLE) ) allocate( NoahmpIO%FOLNMXI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%AREF_TABLE) ) allocate( NoahmpIO%AREF_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%PSNRF_TABLE) ) allocate( NoahmpIO%PSNRF_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%I2PAR_TABLE) ) allocate( NoahmpIO%I2PAR_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%TASSIM0_TABLE) ) allocate( NoahmpIO%TASSIM0_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%TASSIM1_TABLE) ) allocate( NoahmpIO%TASSIM1_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%TASSIM2_TABLE) ) allocate( NoahmpIO%TASSIM2_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%K_TABLE) ) allocate( NoahmpIO%K_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%EPSI_TABLE) ) allocate( NoahmpIO%EPSI_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%Q10MR_TABLE) ) allocate( NoahmpIO%Q10MR_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%LEFREEZ_TABLE) ) allocate( NoahmpIO%LEFREEZ_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%DILE_FC_TABLE) ) allocate( NoahmpIO%DILE_FC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%DILE_FW_TABLE) ) allocate( NoahmpIO%DILE_FW_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%FRA_GR_TABLE) ) allocate( NoahmpIO%FRA_GR_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%LF_OVRC_TABLE) ) allocate( NoahmpIO%LF_OVRC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%ST_OVRC_TABLE) ) allocate( NoahmpIO%ST_OVRC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%RT_OVRC_TABLE) ) allocate( NoahmpIO%RT_OVRC_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%LFMR25_TABLE) ) allocate( NoahmpIO%LFMR25_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%STMR25_TABLE) ) allocate( NoahmpIO%STMR25_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%RTMR25_TABLE) ) allocate( NoahmpIO%RTMR25_TABLE (NCROP) ) + if ( .not. allocated (NoahmpIO%GRAINMR25_TABLE) ) allocate( NoahmpIO%GRAINMR25_TABLE(NCROP) ) + if ( .not. allocated (NoahmpIO%LFPT_TABLE) ) allocate( NoahmpIO%LFPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%STPT_TABLE) ) allocate( NoahmpIO%STPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%RTPT_TABLE) ) allocate( NoahmpIO%RTPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%GRAINPT_TABLE) ) allocate( NoahmpIO%GRAINPT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%LFCT_TABLE) ) allocate( NoahmpIO%LFCT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%STCT_TABLE) ) allocate( NoahmpIO%STCT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%RTCT_TABLE) ) allocate( NoahmpIO%RTCT_TABLE (NCROP,NSTAGE) ) + if ( .not. allocated (NoahmpIO%BIO2LAI_TABLE) ) allocate( NoahmpIO%BIO2LAI_TABLE (NCROP) ) + + !--------------------------------------------------------------- + ! intialization to bad value, so that if the namelist read fails, + ! we come to a screeching halt as soon as we try to use anything + !--------------------------------------------------------------- + + ! vegetation parameters + NoahmpIO%ISURBAN_TABLE = undefined_int + NoahmpIO%ISWATER_TABLE = undefined_int + NoahmpIO%ISBARREN_TABLE = undefined_int + NoahmpIO%ISICE_TABLE = undefined_int + NoahmpIO%ISCROP_TABLE = undefined_int + NoahmpIO%EBLFOREST_TABLE = undefined_int + NoahmpIO%NATURAL_TABLE = undefined_int + NoahmpIO%URBTYPE_beg = undefined_int + NoahmpIO%LCZ_1_TABLE = undefined_int + NoahmpIO%LCZ_2_TABLE = undefined_int + NoahmpIO%LCZ_3_TABLE = undefined_int + NoahmpIO%LCZ_4_TABLE = undefined_int + NoahmpIO%LCZ_5_TABLE = undefined_int + NoahmpIO%LCZ_6_TABLE = undefined_int + NoahmpIO%LCZ_7_TABLE = undefined_int + NoahmpIO%LCZ_8_TABLE = undefined_int + NoahmpIO%LCZ_9_TABLE = undefined_int + NoahmpIO%LCZ_10_TABLE = undefined_int + NoahmpIO%LCZ_11_TABLE = undefined_int + NoahmpIO%CH2OP_TABLE = undefined_real + NoahmpIO%DLEAF_TABLE = undefined_real + NoahmpIO%Z0MVT_TABLE = undefined_real + NoahmpIO%HVT_TABLE = undefined_real + NoahmpIO%HVB_TABLE = undefined_real + NoahmpIO%DEN_TABLE = undefined_real + NoahmpIO%RC_TABLE = undefined_real + NoahmpIO%MFSNO_TABLE = undefined_real + NoahmpIO%SCFFAC_TABLE = undefined_real + NoahmpIO%CBIOM_TABLE = undefined_real + NoahmpIO%RHOL_TABLE = undefined_real + NoahmpIO%RHOS_TABLE = undefined_real + NoahmpIO%TAUL_TABLE = undefined_real + NoahmpIO%TAUS_TABLE = undefined_real + NoahmpIO%XL_TABLE = undefined_real + NoahmpIO%CWPVT_TABLE = undefined_real + NoahmpIO%C3PSN_TABLE = undefined_real + NoahmpIO%KC25_TABLE = undefined_real + NoahmpIO%AKC_TABLE = undefined_real + NoahmpIO%KO25_TABLE = undefined_real + NoahmpIO%AKO_TABLE = undefined_real + NoahmpIO%AVCMX_TABLE = undefined_real + NoahmpIO%AQE_TABLE = undefined_real + NoahmpIO%LTOVRC_TABLE = undefined_real + NoahmpIO%DILEFC_TABLE = undefined_real + NoahmpIO%DILEFW_TABLE = undefined_real + NoahmpIO%RMF25_TABLE = undefined_real + NoahmpIO%SLA_TABLE = undefined_real + NoahmpIO%FRAGR_TABLE = undefined_real + NoahmpIO%TMIN_TABLE = undefined_real + NoahmpIO%VCMX25_TABLE = undefined_real + NoahmpIO%TDLEF_TABLE = undefined_real + NoahmpIO%BP_TABLE = undefined_real + NoahmpIO%MP_TABLE = undefined_real + NoahmpIO%QE25_TABLE = undefined_real + NoahmpIO%RMS25_TABLE = undefined_real + NoahmpIO%RMR25_TABLE = undefined_real + NoahmpIO%ARM_TABLE = undefined_real + NoahmpIO%FOLNMX_TABLE = undefined_real + NoahmpIO%WDPOOL_TABLE = undefined_real + NoahmpIO%WRRAT_TABLE = undefined_real + NoahmpIO%MRP_TABLE = undefined_real + NoahmpIO%SAIM_TABLE = undefined_real + NoahmpIO%LAIM_TABLE = undefined_real + NoahmpIO%NROOT_TABLE = undefined_real + NoahmpIO%RGL_TABLE = undefined_real + NoahmpIO%RS_TABLE = undefined_real + NoahmpIO%HS_TABLE = undefined_real + NoahmpIO%TOPT_TABLE = undefined_real + NoahmpIO%RSMAX_TABLE = undefined_real + NoahmpIO%RTOVRC_TABLE = undefined_real + NoahmpIO%RSWOODC_TABLE = undefined_real + NoahmpIO%BF_TABLE = undefined_real + NoahmpIO%WSTRC_TABLE = undefined_real + NoahmpIO%LAIMIN_TABLE = undefined_real + NoahmpIO%XSAMIN_TABLE = undefined_real + + ! soil parameters + NoahmpIO%SLCATS_TABLE = undefined_int + NoahmpIO%BEXP_TABLE = undefined_real + NoahmpIO%SMCDRY_TABLE = undefined_real + NoahmpIO%SMCMAX_TABLE = undefined_real + NoahmpIO%SMCREF_TABLE = undefined_real + NoahmpIO%PSISAT_TABLE = undefined_real + NoahmpIO%DKSAT_TABLE = undefined_real + NoahmpIO%DWSAT_TABLE = undefined_real + NoahmpIO%SMCWLT_TABLE = undefined_real + NoahmpIO%QUARTZ_TABLE = undefined_real + NoahmpIO%BVIC_TABLE = undefined_real + NoahmpIO%AXAJ_TABLE = undefined_real + NoahmpIO%BXAJ_TABLE = undefined_real + NoahmpIO%XXAJ_TABLE = undefined_real + NoahmpIO%BDVIC_TABLE = undefined_real + NoahmpIO%GDVIC_TABLE = undefined_real + NoahmpIO%BBVIC_TABLE = undefined_real + + ! general parameters + NoahmpIO%SLOPE_TABLE = undefined_real + NoahmpIO%CSOIL_TABLE = undefined_real + NoahmpIO%REFDK_TABLE = undefined_real + NoahmpIO%REFKDT_TABLE = undefined_real + NoahmpIO%FRZK_TABLE = undefined_real + NoahmpIO%ZBOT_TABLE = undefined_real + NoahmpIO%CZIL_TABLE = undefined_real + + ! radiation parameters + NoahmpIO%ALBSAT_TABLE = undefined_real + NoahmpIO%ALBDRY_TABLE = undefined_real + NoahmpIO%ALBICE_TABLE = undefined_real + NoahmpIO%ALBLAK_TABLE = undefined_real + NoahmpIO%OMEGAS_TABLE = undefined_real + NoahmpIO%BETADS_TABLE = undefined_real + NoahmpIO%BETAIS_TABLE = undefined_real + NoahmpIO%EG_TABLE = undefined_real + NoahmpIO%EICE_TABLE = undefined_real + + ! global parameters + NoahmpIO%CO2_TABLE = undefined_real + NoahmpIO%O2_TABLE = undefined_real + NoahmpIO%TIMEAN_TABLE = undefined_real + NoahmpIO%FSATMX_TABLE = undefined_real + NoahmpIO%Z0SNO_TABLE = undefined_real + NoahmpIO%SSI_TABLE = undefined_real + NoahmpIO%SNOW_RET_FAC_TABLE = undefined_real + NoahmpIO%SNOW_EMIS_TABLE = undefined_real + NoahmpIO%SWEMX_TABLE = undefined_real + NoahmpIO%TAU0_TABLE = undefined_real + NoahmpIO%GRAIN_GROWTH_TABLE = undefined_real + NoahmpIO%EXTRA_GROWTH_TABLE = undefined_real + NoahmpIO%DIRT_SOOT_TABLE = undefined_real + NoahmpIO%BATS_COSZ_TABLE = undefined_real + NoahmpIO%BATS_VIS_NEW_TABLE = undefined_real + NoahmpIO%BATS_NIR_NEW_TABLE = undefined_real + NoahmpIO%BATS_VIS_AGE_TABLE = undefined_real + NoahmpIO%BATS_NIR_AGE_TABLE = undefined_real + NoahmpIO%BATS_VIS_DIR_TABLE = undefined_real + NoahmpIO%BATS_NIR_DIR_TABLE = undefined_real + NoahmpIO%RSURF_SNOW_TABLE = undefined_real + NoahmpIO%RSURF_EXP_TABLE = undefined_real + NoahmpIO%C2_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%C3_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%C4_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%C5_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%DM_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%ETA0_SNOWCOMPACT_TABLE = undefined_real + NoahmpIO%SNLIQMAXFRAC_TABLE = undefined_real + NoahmpIO%SWEMAXGLA_TABLE = undefined_real + NoahmpIO%WSLMAX_TABLE = undefined_real + NoahmpIO%ROUS_TABLE = undefined_real + NoahmpIO%CMIC_TABLE = undefined_real + NoahmpIO%SNOWDEN_MAX_TABLE = undefined_real + NoahmpIO%CLASS_ALB_REF_TABLE = undefined_real + NoahmpIO%CLASS_SNO_AGE_TABLE = undefined_real + NoahmpIO%CLASS_ALB_NEW_TABLE = undefined_real + NoahmpIO%PSIWLT_TABLE = undefined_real + NoahmpIO%Z0SOIL_TABLE = undefined_real + NoahmpIO%Z0LAKE_TABLE = undefined_real + + ! irrigation parameters + NoahmpIO%IRR_HAR_TABLE = undefined_int + NoahmpIO%IRR_FRAC_TABLE = undefined_real + NoahmpIO%IRR_LAI_TABLE = undefined_real + NoahmpIO%IRR_MAD_TABLE = undefined_real + NoahmpIO%FILOSS_TABLE = undefined_real + NoahmpIO%SPRIR_RATE_TABLE = undefined_real + NoahmpIO%MICIR_RATE_TABLE = undefined_real + NoahmpIO%FIRTFAC_TABLE = undefined_real + NoahmpIO%IR_RAIN_TABLE = undefined_real + + ! crop parameters + NoahmpIO%DEFAULT_CROP_TABLE = undefined_int + NoahmpIO%PLTDAY_TABLE = undefined_int + NoahmpIO%HSDAY_TABLE = undefined_int + NoahmpIO%PLANTPOP_TABLE = undefined_real + NoahmpIO%IRRI_TABLE = undefined_real + NoahmpIO%GDDTBASE_TABLE = undefined_real + NoahmpIO%GDDTCUT_TABLE = undefined_real + NoahmpIO%GDDS1_TABLE = undefined_real + NoahmpIO%GDDS2_TABLE = undefined_real + NoahmpIO%GDDS3_TABLE = undefined_real + NoahmpIO%GDDS4_TABLE = undefined_real + NoahmpIO%GDDS5_TABLE = undefined_real + NoahmpIO%C3PSNI_TABLE = undefined_real + NoahmpIO%KC25I_TABLE = undefined_real + NoahmpIO%AKCI_TABLE = undefined_real + NoahmpIO%KO25I_TABLE = undefined_real + NoahmpIO%AKOI_TABLE = undefined_real + NoahmpIO%AVCMXI_TABLE = undefined_real + NoahmpIO%VCMX25I_TABLE = undefined_real + NoahmpIO%BPI_TABLE = undefined_real + NoahmpIO%MPI_TABLE = undefined_real + NoahmpIO%FOLNMXI_TABLE = undefined_real + NoahmpIO%QE25I_TABLE = undefined_real + NoahmpIO%AREF_TABLE = undefined_real + NoahmpIO%PSNRF_TABLE = undefined_real + NoahmpIO%I2PAR_TABLE = undefined_real + NoahmpIO%TASSIM0_TABLE = undefined_real + NoahmpIO%TASSIM1_TABLE = undefined_real + NoahmpIO%TASSIM2_TABLE = undefined_real + NoahmpIO%K_TABLE = undefined_real + NoahmpIO%EPSI_TABLE = undefined_real + NoahmpIO%Q10MR_TABLE = undefined_real + NoahmpIO%LEFREEZ_TABLE = undefined_real + NoahmpIO%DILE_FC_TABLE = undefined_real + NoahmpIO%DILE_FW_TABLE = undefined_real + NoahmpIO%FRA_GR_TABLE = undefined_real + NoahmpIO%LF_OVRC_TABLE = undefined_real + NoahmpIO%ST_OVRC_TABLE = undefined_real + NoahmpIO%RT_OVRC_TABLE = undefined_real + NoahmpIO%LFMR25_TABLE = undefined_real + NoahmpIO%STMR25_TABLE = undefined_real + NoahmpIO%RTMR25_TABLE = undefined_real + NoahmpIO%GRAINMR25_TABLE = undefined_real + NoahmpIO%LFPT_TABLE = undefined_real + NoahmpIO%STPT_TABLE = undefined_real + NoahmpIO%RTPT_TABLE = undefined_real + NoahmpIO%GRAINPT_TABLE = undefined_real + NoahmpIO%LFCT_TABLE = undefined_real + NoahmpIO%STCT_TABLE = undefined_real + NoahmpIO%RTCT_TABLE = undefined_real + NoahmpIO%BIO2LAI_TABLE = undefined_real + + ! tile drainage parameters + NoahmpIO%DRAIN_LAYER_OPT_TABLE = undefined_int + NoahmpIO%TD_DEPTH_TABLE = undefined_int + NoahmpIO%TDSMC_FAC_TABLE = undefined_real + NoahmpIO%TD_DC_TABLE = undefined_real + NoahmpIO%TD_DCOEF_TABLE = undefined_real + NoahmpIO%TD_D_TABLE = undefined_real + NoahmpIO%TD_ADEPTH_TABLE = undefined_real + NoahmpIO%TD_RADI_TABLE = undefined_real + NoahmpIO%TD_SPAC_TABLE = undefined_real + NoahmpIO%TD_DDRAIN_TABLE = undefined_real + NoahmpIO%KLAT_FAC_TABLE = undefined_real + + ! optional parameters + NoahmpIO%sr2006_theta_1500t_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_d_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_e_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_f_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500t_g_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_1500_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_d_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_e_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_f_TABLE = undefined_real + NoahmpIO%sr2006_theta_33t_g_TABLE = undefined_real + NoahmpIO%sr2006_theta_33_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_33_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_33_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_b_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_c_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_d_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_e_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_f_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33t_g_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33_a_TABLE = undefined_real + NoahmpIO%sr2006_theta_s33_b_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_a_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_b_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_c_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_d_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_e_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_f_TABLE = undefined_real + NoahmpIO%sr2006_psi_et_g_TABLE = undefined_real + NoahmpIO%sr2006_psi_e_a_TABLE = undefined_real + NoahmpIO%sr2006_psi_e_b_TABLE = undefined_real + NoahmpIO%sr2006_psi_e_c_TABLE = undefined_real + NoahmpIO%sr2006_smcmax_a_TABLE = undefined_real + NoahmpIO%sr2006_smcmax_b_TABLE = undefined_real + + !--------------------------------------------------------------- + ! transfer values from table to input variables + !--------------------------------------------------------------- + + !---------------- NoahmpTable.TBL vegetation parameters + + DATASET_IDENTIFIER = NoahmpIO%LLANDUSE + + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + + if ( trim(DATASET_IDENTIFIER) == "USGS" ) then + read(15, noahmp_usgs_veg_categories) + read(15, noahmp_usgs_parameters) + elseif ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then + read(15,noahmp_modis_veg_categories) + read(15,noahmp_modis_parameters) + else + write(*,'("WARNING: Unrecognized DATASET_IDENTIFIER in subroutine ReadNoahmpTable")') + write(*,'("WARNING: DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) + endif + close(15) + + ! assign values + NoahmpIO%ISURBAN_TABLE = ISURBAN + NoahmpIO%ISWATER_TABLE = ISWATER + NoahmpIO%ISBARREN_TABLE = ISBARREN + NoahmpIO%ISICE_TABLE = ISICE + NoahmpIO%ISCROP_TABLE = ISCROP + NoahmpIO%EBLFOREST_TABLE = EBLFOREST + NoahmpIO%NATURAL_TABLE = NATURAL + NoahmpIO%URBTYPE_beg = URBTYPE_beg + NoahmpIO%LCZ_1_TABLE = LCZ_1 + NoahmpIO%LCZ_2_TABLE = LCZ_2 + NoahmpIO%LCZ_3_TABLE = LCZ_3 + NoahmpIO%LCZ_4_TABLE = LCZ_4 + NoahmpIO%LCZ_5_TABLE = LCZ_5 + NoahmpIO%LCZ_6_TABLE = LCZ_6 + NoahmpIO%LCZ_7_TABLE = LCZ_7 + NoahmpIO%LCZ_8_TABLE = LCZ_8 + NoahmpIO%LCZ_9_TABLE = LCZ_9 + NoahmpIO%LCZ_10_TABLE = LCZ_10 + NoahmpIO%LCZ_11_TABLE = LCZ_11 + NoahmpIO%CH2OP_TABLE (1:NVEG) = CH2OP (1:NVEG) + NoahmpIO%DLEAF_TABLE (1:NVEG) = DLEAF (1:NVEG) + NoahmpIO%Z0MVT_TABLE (1:NVEG) = Z0MVT (1:NVEG) + NoahmpIO%HVT_TABLE (1:NVEG) = HVT (1:NVEG) + NoahmpIO%HVB_TABLE (1:NVEG) = HVB (1:NVEG) + NoahmpIO%DEN_TABLE (1:NVEG) = DEN (1:NVEG) + NoahmpIO%RC_TABLE (1:NVEG) = RC (1:NVEG) + NoahmpIO%MFSNO_TABLE (1:NVEG) = MFSNO (1:NVEG) + NoahmpIO%SCFFAC_TABLE (1:NVEG) = SCFFAC (1:NVEG) + NoahmpIO%CBIOM_TABLE (1:NVEG) = CBIOM (1:NVEG) + NoahmpIO%XL_TABLE (1:NVEG) = XL (1:NVEG) + NoahmpIO%CWPVT_TABLE (1:NVEG) = CWPVT (1:NVEG) + NoahmpIO%C3PSN_TABLE (1:NVEG) = C3PSN (1:NVEG) + NoahmpIO%KC25_TABLE (1:NVEG) = KC25 (1:NVEG) + NoahmpIO%AKC_TABLE (1:NVEG) = AKC (1:NVEG) + NoahmpIO%KO25_TABLE (1:NVEG) = KO25 (1:NVEG) + NoahmpIO%AKO_TABLE (1:NVEG) = AKO (1:NVEG) + NoahmpIO%AVCMX_TABLE (1:NVEG) = AVCMX (1:NVEG) + NoahmpIO%AQE_TABLE (1:NVEG) = AQE (1:NVEG) + NoahmpIO%LTOVRC_TABLE (1:NVEG) = LTOVRC (1:NVEG) + NoahmpIO%DILEFC_TABLE (1:NVEG) = DILEFC (1:NVEG) + NoahmpIO%DILEFW_TABLE (1:NVEG) = DILEFW (1:NVEG) + NoahmpIO%RMF25_TABLE (1:NVEG) = RMF25 (1:NVEG) + NoahmpIO%SLA_TABLE (1:NVEG) = SLA (1:NVEG) + NoahmpIO%FRAGR_TABLE (1:NVEG) = FRAGR (1:NVEG) + NoahmpIO%TMIN_TABLE (1:NVEG) = TMIN (1:NVEG) + NoahmpIO%VCMX25_TABLE (1:NVEG) = VCMX25 (1:NVEG) + NoahmpIO%TDLEF_TABLE (1:NVEG) = TDLEF (1:NVEG) + NoahmpIO%BP_TABLE (1:NVEG) = BP (1:NVEG) + NoahmpIO%MP_TABLE (1:NVEG) = MP (1:NVEG) + NoahmpIO%QE25_TABLE (1:NVEG) = QE25 (1:NVEG) + NoahmpIO%RMS25_TABLE (1:NVEG) = RMS25 (1:NVEG) + NoahmpIO%RMR25_TABLE (1:NVEG) = RMR25 (1:NVEG) + NoahmpIO%ARM_TABLE (1:NVEG) = ARM (1:NVEG) + NoahmpIO%FOLNMX_TABLE (1:NVEG) = FOLNMX (1:NVEG) + NoahmpIO%WDPOOL_TABLE (1:NVEG) = WDPOOL (1:NVEG) + NoahmpIO%WRRAT_TABLE (1:NVEG) = WRRAT (1:NVEG) + NoahmpIO%MRP_TABLE (1:NVEG) = MRP (1:NVEG) + NoahmpIO%NROOT_TABLE (1:NVEG) = NROOT (1:NVEG) + NoahmpIO%RGL_TABLE (1:NVEG) = RGL (1:NVEG) + NoahmpIO%RS_TABLE (1:NVEG) = RS (1:NVEG) + NoahmpIO%HS_TABLE (1:NVEG) = HS (1:NVEG) + NoahmpIO%TOPT_TABLE (1:NVEG) = TOPT (1:NVEG) + NoahmpIO%RSMAX_TABLE (1:NVEG) = RSMAX (1:NVEG) + NoahmpIO%RTOVRC_TABLE (1:NVEG) = RTOVRC (1:NVEG) + NoahmpIO%RSWOODC_TABLE(1:NVEG) = RSWOODC(1:NVEG) + NoahmpIO%BF_TABLE (1:NVEG) = BF (1:NVEG) + NoahmpIO%WSTRC_TABLE (1:NVEG) = WSTRC (1:NVEG) + NoahmpIO%LAIMIN_TABLE (1:NVEG) = LAIMIN (1:NVEG) + NoahmpIO%XSAMIN_TABLE (1:NVEG) = XSAMIN (1:NVEG) + + NoahmpIO%SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG) + NoahmpIO%SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG) + NoahmpIO%LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG) + NoahmpIO%RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG) !leaf reflectance: 1=vis, 2=nir + NoahmpIO%RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG) !leaf reflectance: 1=vis, 2=nir + NoahmpIO%RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG) !stem reflectance: 1=vis, 2=nir + NoahmpIO%RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG) !stem reflectance: 1=vis, 2=nir + NoahmpIO%TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG) !leaf transmittance: 1=vis, 2=nir + NoahmpIO%TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG) !leaf transmittance: 1=vis, 2=nir + NoahmpIO%TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG) !stem transmittance: 1=vis, 2=nir + NoahmpIO%TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG) !stem transmittance: 1=vis, 2=nir + + !---------------- NoahmpTable.TBL soil parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15, noahmp_stas_soil_categories) + if ( trim(SLTYPE) == "STAS" ) then + read(15, noahmp_soil_stas_parameters) + elseif ( trim(SLTYPE) == "STAS_RUC" ) then + read(15, noahmp_soil_stas_ruc_parameters) + else + write(*,'("WARNING: Unrecognized SOILTYPE in subroutine ReadNoahmpTable")') + write(*,'("WARNING: DATASET_IDENTIFIER = ''", A, "''")') trim(SLTYPE) + endif + close(15) + + ! assign values + NoahmpIO%SLCATS_TABLE = SLCATS + NoahmpIO%BEXP_TABLE (1:SLCATS) = BB (1:SLCATS) + NoahmpIO%SMCDRY_TABLE(1:SLCATS) = DRYSMC(1:SLCATS) + NoahmpIO%SMCMAX_TABLE(1:SLCATS) = MAXSMC(1:SLCATS) + NoahmpIO%SMCREF_TABLE(1:SLCATS) = REFSMC(1:SLCATS) + NoahmpIO%PSISAT_TABLE(1:SLCATS) = SATPSI(1:SLCATS) + NoahmpIO%DKSAT_TABLE (1:SLCATS) = SATDK (1:SLCATS) + NoahmpIO%DWSAT_TABLE (1:SLCATS) = SATDW (1:SLCATS) + NoahmpIO%SMCWLT_TABLE(1:SLCATS) = WLTSMC(1:SLCATS) + NoahmpIO%QUARTZ_TABLE(1:SLCATS) = QTZ (1:SLCATS) + NoahmpIO%BVIC_TABLE (1:SLCATS) = BVIC (1:SLCATS) + NoahmpIO%AXAJ_TABLE (1:SLCATS) = AXAJ (1:SLCATS) + NoahmpIO%BXAJ_TABLE (1:SLCATS) = BXAJ (1:SLCATS) + NoahmpIO%XXAJ_TABLE (1:SLCATS) = XXAJ (1:SLCATS) + NoahmpIO%BDVIC_TABLE (1:SLCATS) = BDVIC (1:SLCATS) + NoahmpIO%GDVIC_TABLE (1:SLCATS) = GDVIC (1:SLCATS) + NoahmpIO%BBVIC_TABLE (1:SLCATS) = BBVIC (1:SLCATS) + + !---------------- NoahmpTable.TBL general parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if ( ierr /= 0 ) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15, noahmp_general_parameters) + close(15) + + ! assign values + NoahmpIO%SLOPE_TABLE(1:NUM_SLOPE) = SLOPE_DATA(1:NUM_SLOPE) + NoahmpIO%CSOIL_TABLE = CSOIL_DATA + NoahmpIO%REFDK_TABLE = REFDK_DATA + NoahmpIO%REFKDT_TABLE = REFKDT_DATA + NoahmpIO%FRZK_TABLE = FRZK_DATA + NoahmpIO%ZBOT_TABLE = ZBOT_DATA + NoahmpIO%CZIL_TABLE = CZIL_DATA + + !---------------- NoahmpTable.TBL radiation parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_rad_parameters) + close(15) + + ! assign values + NoahmpIO%ALBSAT_TABLE(:,1) = ALBSAT_VIS ! saturated soil albedos: 1=vis, 2=nir + NoahmpIO%ALBSAT_TABLE(:,2) = ALBSAT_NIR ! saturated soil albedos: 1=vis, 2=nir + NoahmpIO%ALBDRY_TABLE(:,1) = ALBDRY_VIS ! dry soil albedos: 1=vis, 2=nir + NoahmpIO%ALBDRY_TABLE(:,2) = ALBDRY_NIR ! dry soil albedos: 1=vis, 2=nir + NoahmpIO%ALBICE_TABLE = ALBICE + NoahmpIO%ALBLAK_TABLE = ALBLAK + NoahmpIO%OMEGAS_TABLE = OMEGAS + NoahmpIO%BETADS_TABLE = BETADS + NoahmpIO%BETAIS_TABLE = BETAIS + NoahmpIO%EG_TABLE = EG + NoahmpIO%EICE_TABLE = EICE + + !---------------- NoahmpTable.TBL global parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_global_parameters) + close(15) + + ! assign values + NoahmpIO%CO2_TABLE = CO2 + NoahmpIO%O2_TABLE = O2 + NoahmpIO%TIMEAN_TABLE = TIMEAN + NoahmpIO%FSATMX_TABLE = FSATMX + NoahmpIO%Z0SNO_TABLE = Z0SNO + NoahmpIO%SSI_TABLE = SSI + NoahmpIO%SNOW_RET_FAC_TABLE = SNOW_RET_FAC + NoahmpIO%SNOW_EMIS_TABLE = SNOW_EMIS + NoahmpIO%SWEMX_TABLE = SWEMX + NoahmpIO%TAU0_TABLE = TAU0 + NoahmpIO%GRAIN_GROWTH_TABLE = GRAIN_GROWTH + NoahmpIO%EXTRA_GROWTH_TABLE = EXTRA_GROWTH + NoahmpIO%DIRT_SOOT_TABLE = DIRT_SOOT + NoahmpIO%BATS_COSZ_TABLE = BATS_COSZ + NoahmpIO%BATS_VIS_NEW_TABLE = BATS_VIS_NEW + NoahmpIO%BATS_NIR_NEW_TABLE = BATS_NIR_NEW + NoahmpIO%BATS_VIS_AGE_TABLE = BATS_VIS_AGE + NoahmpIO%BATS_NIR_AGE_TABLE = BATS_NIR_AGE + NoahmpIO%BATS_VIS_DIR_TABLE = BATS_VIS_DIR + NoahmpIO%BATS_NIR_DIR_TABLE = BATS_NIR_DIR + NoahmpIO%RSURF_SNOW_TABLE = RSURF_SNOW + NoahmpIO%RSURF_EXP_TABLE = RSURF_EXP + NoahmpIO%C2_SNOWCOMPACT_TABLE = C2_SNOWCOMPACT + NoahmpIO%C3_SNOWCOMPACT_TABLE = C3_SNOWCOMPACT + NoahmpIO%C4_SNOWCOMPACT_TABLE = C4_SNOWCOMPACT + NoahmpIO%C5_SNOWCOMPACT_TABLE = C5_SNOWCOMPACT + NoahmpIO%DM_SNOWCOMPACT_TABLE = DM_SNOWCOMPACT + NoahmpIO%ETA0_SNOWCOMPACT_TABLE = ETA0_SNOWCOMPACT + NoahmpIO%SNLIQMAXFRAC_TABLE = SNLIQMAXFRAC + NoahmpIO%SWEMAXGLA_TABLE = SWEMAXGLA + NoahmpIO%WSLMAX_TABLE = WSLMAX + NoahmpIO%ROUS_TABLE = ROUS + NoahmpIO%CMIC_TABLE = CMIC + NoahmpIO%SNOWDEN_MAX_TABLE = SNOWDEN_MAX + NoahmpIO%CLASS_ALB_REF_TABLE = CLASS_ALB_REF + NoahmpIO%CLASS_SNO_AGE_TABLE = CLASS_SNO_AGE + NoahmpIO%CLASS_ALB_NEW_TABLE = CLASS_ALB_NEW + NoahmpIO%PSIWLT_TABLE = PSIWLT + NoahmpIO%Z0SOIL_TABLE = Z0SOIL + NoahmpIO%Z0LAKE_TABLE = Z0LAKE + + !---------------- NoahmpTable.TBL irrigation parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_irrigation_parameters) + close(15) + if ( (FILOSS < 0.0) .or. (FILOSS > 0.99) ) then + write(*,'("WARNING: FILOSS should be >=0.0 and <=0.99")') + stop "STOP in NoahMP_irrigation_parameters" + endif + + ! assign values + NoahmpIO%IRR_FRAC_TABLE = IRR_FRAC + NoahmpIO%IRR_HAR_TABLE = IRR_HAR + NoahmpIO%IRR_LAI_TABLE = IRR_LAI + NoahmpIO%IRR_MAD_TABLE = IRR_MAD + NoahmpIO%FILOSS_TABLE = FILOSS + NoahmpIO%SPRIR_RATE_TABLE = SPRIR_RATE + NoahmpIO%MICIR_RATE_TABLE = MICIR_RATE + NoahmpIO%FIRTFAC_TABLE = FIRTFAC + NoahmpIO%IR_RAIN_TABLE = IR_RAIN + + !---------------- NoahmpTable.TBL crop parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_crop_parameters) + close(15) + + ! assign values + NoahmpIO%DEFAULT_CROP_TABLE = DEFAULT_CROP + NoahmpIO%PLTDAY_TABLE = PLTDAY + NoahmpIO%HSDAY_TABLE = HSDAY + NoahmpIO%PLANTPOP_TABLE = PLANTPOP + NoahmpIO%IRRI_TABLE = IRRI + NoahmpIO%GDDTBASE_TABLE = GDDTBASE + NoahmpIO%GDDTCUT_TABLE = GDDTCUT + NoahmpIO%GDDS1_TABLE = GDDS1 + NoahmpIO%GDDS2_TABLE = GDDS2 + NoahmpIO%GDDS3_TABLE = GDDS3 + NoahmpIO%GDDS4_TABLE = GDDS4 + NoahmpIO%GDDS5_TABLE = GDDS5 + NoahmpIO%C3PSNI_TABLE (1:5) = C3PSNI (1:5) + NoahmpIO%KC25I_TABLE (1:5) = KC25I (1:5) + NoahmpIO%AKCI_TABLE (1:5) = AKCI (1:5) + NoahmpIO%KO25I_TABLE (1:5) = KO25I (1:5) + NoahmpIO%AKOI_TABLE (1:5) = AKOI (1:5) + NoahmpIO%AVCMXI_TABLE (1:5) = AVCMXI (1:5) + NoahmpIO%VCMX25I_TABLE(1:5) = VCMX25I(1:5) + NoahmpIO%BPI_TABLE (1:5) = BPI (1:5) + NoahmpIO%MPI_TABLE (1:5) = MPI (1:5) + NoahmpIO%FOLNMXI_TABLE(1:5) = FOLNMXI(1:5) + NoahmpIO%QE25I_TABLE (1:5) = QE25I (1:5) + NoahmpIO%AREF_TABLE = AREF + NoahmpIO%PSNRF_TABLE = PSNRF + NoahmpIO%I2PAR_TABLE = I2PAR + NoahmpIO%TASSIM0_TABLE = TASSIM0 + NoahmpIO%TASSIM1_TABLE = TASSIM1 + NoahmpIO%TASSIM2_TABLE = TASSIM2 + NoahmpIO%K_TABLE = K + NoahmpIO%EPSI_TABLE = EPSI + NoahmpIO%Q10MR_TABLE = Q10MR + NoahmpIO%LEFREEZ_TABLE = LEFREEZ + NoahmpIO%FRA_GR_TABLE = FRA_GR + NoahmpIO%LFMR25_TABLE = LFMR25 + NoahmpIO%STMR25_TABLE = STMR25 + NoahmpIO%RTMR25_TABLE = RTMR25 + NoahmpIO%GRAINMR25_TABLE = GRAINMR25 + NoahmpIO%BIO2LAI_TABLE = BIO2LAI + NoahmpIO%DILE_FC_TABLE(:,1) = DILE_FC_S1 + NoahmpIO%DILE_FC_TABLE(:,2) = DILE_FC_S2 + NoahmpIO%DILE_FC_TABLE(:,3) = DILE_FC_S3 + NoahmpIO%DILE_FC_TABLE(:,4) = DILE_FC_S4 + NoahmpIO%DILE_FC_TABLE(:,5) = DILE_FC_S5 + NoahmpIO%DILE_FC_TABLE(:,6) = DILE_FC_S6 + NoahmpIO%DILE_FC_TABLE(:,7) = DILE_FC_S7 + NoahmpIO%DILE_FC_TABLE(:,8) = DILE_FC_S8 + NoahmpIO%DILE_FW_TABLE(:,1) = DILE_FW_S1 + NoahmpIO%DILE_FW_TABLE(:,2) = DILE_FW_S2 + NoahmpIO%DILE_FW_TABLE(:,3) = DILE_FW_S3 + NoahmpIO%DILE_FW_TABLE(:,4) = DILE_FW_S4 + NoahmpIO%DILE_FW_TABLE(:,5) = DILE_FW_S5 + NoahmpIO%DILE_FW_TABLE(:,6) = DILE_FW_S6 + NoahmpIO%DILE_FW_TABLE(:,7) = DILE_FW_S7 + NoahmpIO%DILE_FW_TABLE(:,8) = DILE_FW_S8 + NoahmpIO%LF_OVRC_TABLE(:,1) = LF_OVRC_S1 + NoahmpIO%LF_OVRC_TABLE(:,2) = LF_OVRC_S2 + NoahmpIO%LF_OVRC_TABLE(:,3) = LF_OVRC_S3 + NoahmpIO%LF_OVRC_TABLE(:,4) = LF_OVRC_S4 + NoahmpIO%LF_OVRC_TABLE(:,5) = LF_OVRC_S5 + NoahmpIO%LF_OVRC_TABLE(:,6) = LF_OVRC_S6 + NoahmpIO%LF_OVRC_TABLE(:,7) = LF_OVRC_S7 + NoahmpIO%LF_OVRC_TABLE(:,8) = LF_OVRC_S8 + NoahmpIO%ST_OVRC_TABLE(:,1) = ST_OVRC_S1 + NoahmpIO%ST_OVRC_TABLE(:,2) = ST_OVRC_S2 + NoahmpIO%ST_OVRC_TABLE(:,3) = ST_OVRC_S3 + NoahmpIO%ST_OVRC_TABLE(:,4) = ST_OVRC_S4 + NoahmpIO%ST_OVRC_TABLE(:,5) = ST_OVRC_S5 + NoahmpIO%ST_OVRC_TABLE(:,6) = ST_OVRC_S6 + NoahmpIO%ST_OVRC_TABLE(:,7) = ST_OVRC_S7 + NoahmpIO%ST_OVRC_TABLE(:,8) = ST_OVRC_S8 + NoahmpIO%RT_OVRC_TABLE(:,1) = RT_OVRC_S1 + NoahmpIO%RT_OVRC_TABLE(:,2) = RT_OVRC_S2 + NoahmpIO%RT_OVRC_TABLE(:,3) = RT_OVRC_S3 + NoahmpIO%RT_OVRC_TABLE(:,4) = RT_OVRC_S4 + NoahmpIO%RT_OVRC_TABLE(:,5) = RT_OVRC_S5 + NoahmpIO%RT_OVRC_TABLE(:,6) = RT_OVRC_S6 + NoahmpIO%RT_OVRC_TABLE(:,7) = RT_OVRC_S7 + NoahmpIO%RT_OVRC_TABLE(:,8) = RT_OVRC_S8 + NoahmpIO%LFPT_TABLE (:,1) = LFPT_S1 + NoahmpIO%LFPT_TABLE (:,2) = LFPT_S2 + NoahmpIO%LFPT_TABLE (:,3) = LFPT_S3 + NoahmpIO%LFPT_TABLE (:,4) = LFPT_S4 + NoahmpIO%LFPT_TABLE (:,5) = LFPT_S5 + NoahmpIO%LFPT_TABLE (:,6) = LFPT_S6 + NoahmpIO%LFPT_TABLE (:,7) = LFPT_S7 + NoahmpIO%LFPT_TABLE (:,8) = LFPT_S8 + NoahmpIO%STPT_TABLE (:,1) = STPT_S1 + NoahmpIO%STPT_TABLE (:,2) = STPT_S2 + NoahmpIO%STPT_TABLE (:,3) = STPT_S3 + NoahmpIO%STPT_TABLE (:,4) = STPT_S4 + NoahmpIO%STPT_TABLE (:,5) = STPT_S5 + NoahmpIO%STPT_TABLE (:,6) = STPT_S6 + NoahmpIO%STPT_TABLE (:,7) = STPT_S7 + NoahmpIO%STPT_TABLE (:,8) = STPT_S8 + NoahmpIO%RTPT_TABLE (:,1) = RTPT_S1 + NoahmpIO%RTPT_TABLE (:,2) = RTPT_S2 + NoahmpIO%RTPT_TABLE (:,3) = RTPT_S3 + NoahmpIO%RTPT_TABLE (:,4) = RTPT_S4 + NoahmpIO%RTPT_TABLE (:,5) = RTPT_S5 + NoahmpIO%RTPT_TABLE (:,6) = RTPT_S6 + NoahmpIO%RTPT_TABLE (:,7) = RTPT_S7 + NoahmpIO%RTPT_TABLE (:,8) = RTPT_S8 + NoahmpIO%GRAINPT_TABLE(:,1) = GRAINPT_S1 + NoahmpIO%GRAINPT_TABLE(:,2) = GRAINPT_S2 + NoahmpIO%GRAINPT_TABLE(:,3) = GRAINPT_S3 + NoahmpIO%GRAINPT_TABLE(:,4) = GRAINPT_S4 + NoahmpIO%GRAINPT_TABLE(:,5) = GRAINPT_S5 + NoahmpIO%GRAINPT_TABLE(:,6) = GRAINPT_S6 + NoahmpIO%GRAINPT_TABLE(:,7) = GRAINPT_S7 + NoahmpIO%GRAINPT_TABLE(:,8) = GRAINPT_S8 + NoahmpIO%LFCT_TABLE (:,1) = LFCT_S1 + NoahmpIO%LFCT_TABLE (:,2) = LFCT_S2 + NoahmpIO%LFCT_TABLE (:,3) = LFCT_S3 + NoahmpIO%LFCT_TABLE (:,4) = LFCT_S4 + NoahmpIO%LFCT_TABLE (:,5) = LFCT_S5 + NoahmpIO%LFCT_TABLE (:,6) = LFCT_S6 + NoahmpIO%LFCT_TABLE (:,7) = LFCT_S7 + NoahmpIO%LFCT_TABLE (:,8) = LFCT_S8 + NoahmpIO%STCT_TABLE (:,1) = STCT_S1 + NoahmpIO%STCT_TABLE (:,2) = STCT_S2 + NoahmpIO%STCT_TABLE (:,3) = STCT_S3 + NoahmpIO%STCT_TABLE (:,4) = STCT_S4 + NoahmpIO%STCT_TABLE (:,5) = STCT_S5 + NoahmpIO%STCT_TABLE (:,6) = STCT_S6 + NoahmpIO%STCT_TABLE (:,7) = STCT_S7 + NoahmpIO%STCT_TABLE (:,8) = STCT_S8 + NoahmpIO%RTCT_TABLE (:,1) = RTCT_S1 + NoahmpIO%RTCT_TABLE (:,2) = RTCT_S2 + NoahmpIO%RTCT_TABLE (:,3) = RTCT_S3 + NoahmpIO%RTCT_TABLE (:,4) = RTCT_S4 + NoahmpIO%RTCT_TABLE (:,5) = RTCT_S5 + NoahmpIO%RTCT_TABLE (:,6) = RTCT_S6 + NoahmpIO%RTCT_TABLE (:,7) = RTCT_S7 + NoahmpIO%RTCT_TABLE (:,8) = RTCT_S8 + + !---------------- NoahmpTable.TBL tile drainage parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_tiledrain_parameters) + close(15) + + ! assign values + NoahmpIO%DRAIN_LAYER_OPT_TABLE = DRAIN_LAYER_OPT + NoahmpIO%TDSMC_FAC_TABLE(1:NSOILTYPE) = TDSMC_FAC(1:NSOILTYPE) + NoahmpIO%TD_DEPTH_TABLE (1:NSOILTYPE) = TD_DEPTH (1:NSOILTYPE) + NoahmpIO%TD_DC_TABLE (1:NSOILTYPE) = TD_DC (1:NSOILTYPE) + NoahmpIO%TD_DCOEF_TABLE (1:NSOILTYPE) = TD_DCOEF (1:NSOILTYPE) + NoahmpIO%TD_D_TABLE (1:NSOILTYPE) = TD_D (1:NSOILTYPE) + NoahmpIO%TD_ADEPTH_TABLE(1:NSOILTYPE) = TD_ADEPTH(1:NSOILTYPE) + NoahmpIO%TD_RADI_TABLE (1:NSOILTYPE) = TD_RADI (1:NSOILTYPE) + NoahmpIO%TD_SPAC_TABLE (1:NSOILTYPE) = TD_SPAC (1:NSOILTYPE) + NoahmpIO%TD_DDRAIN_TABLE(1:NSOILTYPE) = TD_DDRAIN(1:NSOILTYPE) + NoahmpIO%KLAT_FAC_TABLE (1:NSOILTYPE) = KLAT_FAC (1:NSOILTYPE) + + !---------------- NoahmpTable.TBL optional parameters + inquire( file='NoahmpTable.TBL', exist=file_named ) + if ( file_named ) then + open(15, file="NoahmpTable.TBL", status='old', form='formatted', action='read', iostat=ierr) + else + open(15, status='old', form='formatted', action='read', iostat=ierr) + end if + if (ierr /= 0) then + write(*,'("WARNING: Cannot find file NoahmpTable.TBL")') + endif + read(15,noahmp_optional_parameters) + close(15) + + ! assign values + NoahmpIO%sr2006_theta_1500t_a_TABLE = sr2006_theta_1500t_a + NoahmpIO%sr2006_theta_1500t_b_TABLE = sr2006_theta_1500t_b + NoahmpIO%sr2006_theta_1500t_c_TABLE = sr2006_theta_1500t_c + NoahmpIO%sr2006_theta_1500t_d_TABLE = sr2006_theta_1500t_d + NoahmpIO%sr2006_theta_1500t_e_TABLE = sr2006_theta_1500t_e + NoahmpIO%sr2006_theta_1500t_f_TABLE = sr2006_theta_1500t_f + NoahmpIO%sr2006_theta_1500t_g_TABLE = sr2006_theta_1500t_g + NoahmpIO%sr2006_theta_1500_a_TABLE = sr2006_theta_1500_a + NoahmpIO%sr2006_theta_1500_b_TABLE = sr2006_theta_1500_b + NoahmpIO%sr2006_theta_33t_a_TABLE = sr2006_theta_33t_a + NoahmpIO%sr2006_theta_33t_b_TABLE = sr2006_theta_33t_b + NoahmpIO%sr2006_theta_33t_c_TABLE = sr2006_theta_33t_c + NoahmpIO%sr2006_theta_33t_d_TABLE = sr2006_theta_33t_d + NoahmpIO%sr2006_theta_33t_e_TABLE = sr2006_theta_33t_e + NoahmpIO%sr2006_theta_33t_f_TABLE = sr2006_theta_33t_f + NoahmpIO%sr2006_theta_33t_g_TABLE = sr2006_theta_33t_g + NoahmpIO%sr2006_theta_33_a_TABLE = sr2006_theta_33_a + NoahmpIO%sr2006_theta_33_b_TABLE = sr2006_theta_33_b + NoahmpIO%sr2006_theta_33_c_TABLE = sr2006_theta_33_c + NoahmpIO%sr2006_theta_s33t_a_TABLE = sr2006_theta_s33t_a + NoahmpIO%sr2006_theta_s33t_b_TABLE = sr2006_theta_s33t_b + NoahmpIO%sr2006_theta_s33t_c_TABLE = sr2006_theta_s33t_c + NoahmpIO%sr2006_theta_s33t_d_TABLE = sr2006_theta_s33t_d + NoahmpIO%sr2006_theta_s33t_e_TABLE = sr2006_theta_s33t_e + NoahmpIO%sr2006_theta_s33t_f_TABLE = sr2006_theta_s33t_f + NoahmpIO%sr2006_theta_s33t_g_TABLE = sr2006_theta_s33t_g + NoahmpIO%sr2006_theta_s33_a_TABLE = sr2006_theta_s33_a + NoahmpIO%sr2006_theta_s33_b_TABLE = sr2006_theta_s33_b + NoahmpIO%sr2006_psi_et_a_TABLE = sr2006_psi_et_a + NoahmpIO%sr2006_psi_et_b_TABLE = sr2006_psi_et_b + NoahmpIO%sr2006_psi_et_c_TABLE = sr2006_psi_et_c + NoahmpIO%sr2006_psi_et_d_TABLE = sr2006_psi_et_d + NoahmpIO%sr2006_psi_et_e_TABLE = sr2006_psi_et_e + NoahmpIO%sr2006_psi_et_f_TABLE = sr2006_psi_et_f + NoahmpIO%sr2006_psi_et_g_TABLE = sr2006_psi_et_g + NoahmpIO%sr2006_psi_e_a_TABLE = sr2006_psi_e_a + NoahmpIO%sr2006_psi_e_b_TABLE = sr2006_psi_e_b + NoahmpIO%sr2006_psi_e_c_TABLE = sr2006_psi_e_c + NoahmpIO%sr2006_smcmax_a_TABLE = sr2006_smcmax_a + NoahmpIO%sr2006_smcmax_b_TABLE = sr2006_smcmax_b + + end subroutine NoahmpReadTable + +end module NoahmpReadTableMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpSnowInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpSnowInitMod.F90 new file mode 100644 index 0000000000..56a9aeb96c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/NoahmpSnowInitMod.F90 @@ -0,0 +1,115 @@ + module NoahmpSnowInitMod + +! Module to initialize Noah-MP Snow variables + + use Machine + use NoahmpIOVarType + + implicit none + + contains + + subroutine NoahmpSnowInitMain(NoahmpIO) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOW_INIT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +!local variables + integer :: i,its,ite,iz + real(kind=kind_noahmp), dimension(-NoahmpIO%nsnow+1: 0) :: dzsno + real(kind=kind_noahmp), dimension(-NoahmpIO%nsnow+1:NoahmpIO%nsoil) :: dzsnso + +!------------------------------------------------------------------------------------------ +! Initialize snow arrays for Noah-MP LSM, based in input SNOWDEP, NSNOW +! ISNOWXY is an index array, indicating the index of the top snow layer. Valid indices +! for snow layers range from 0 (no snow) and -1 (shallow snow) to (-NSNOW)+1 (deep snow). +! TSNOXY holds the temperature of the snow layer. Snow layers are initialized with +! temperature = ground temperature [?]. Snow-free levels in the array have value 0.0 +! SNICEXY is the frozen content of a snow layer. Initial estimate based on SNOWH and SNOW +! SNLIQXY is the liquid content of a snow layer. Initialized to 0.0 +! ZNSNOXY is the layer depth from the surface. +!------------------------------------------------------------------------------------------ + + its = NoahmpIO%its + ite = NoahmpIO%ite + + do i = its, ite + + ! initialize snow layers and thickness + ! no explicit snow layer + if ( NoahmpIO%snowh(i) < 0.025 ) then + NoahmpIO%isnowxy(i) = 0 + dzsno(-NoahmpIO%nsnow+1:0) = 0.0 + else + ! 1 layer snow + if ( (NoahmpIO%snowh(i) >= 0.025) .and. (NoahmpIO%snowh(i) <= 0.05) ) then + NoahmpIO%isnowxy(i) = -1 + dzsno(0) = NoahmpIO%snowh(i) + ! 2 layer snow + elseif ( (NoahmpIO%snowh(i) > 0.05) .and. (NoahmpIO%snowh(i) <= 0.10) ) then + NoahmpIO%isnowxy(i) = -2 + dzsno(-1) = NoahmpIO%snowh(i) / 2.0 + dzsno( 0) = NoahmpIO%snowh(i) / 2.0 + ! 2 layer thick snow + elseif ( (NoahmpIO%snowh(i) > 0.10) .and. (NoahmpIO%snowh(i) <= 0.25) ) then + NoahmpIO%isnowxy(i) = -2 + dzsno(-1) = 0.05 + dzsno( 0) = NoahmpIO%snowh(i) - dzsno(-1) + ! 3 layer snow + elseif ( (NoahmpIO%snowh(i) > 0.25) .and. (NoahmpIO%snowh(i) <= 0.45) ) then + NoahmpIO%isnowxy(i) = -3 + dzsno(-2) = 0.05 + dzsno(-1) = 0.5 * (NoahmpIO%snowh(i)-dzsno(-2)) + dzsno( 0) = 0.5 * (NoahmpIO%snowh(i)-dzsno(-2)) + ! 3 layer thick snow + elseif ( NoahmpIO%snowh(i) > 0.45 ) then + NoahmpIO%isnowxy(i) = -3 + dzsno(-2) = 0.05 + dzsno(-1) = 0.20 + dzsno( 0) = NoahmpIO%snowh(i) - dzsno(-1) - dzsno(-2) + else + print*, "problem with the logic assigning snow layers." + stop + endif + endif + + ! initialize snow temperatuer and ice/liquid content + NoahmpIO%tsnoxy (i,-NoahmpIO%nsnow+1:0) = 0.0 + NoahmpIO%snicexy(i,-NoahmpIO%nsnow+1:0) = 0.0 + NoahmpIO%snliqxy(i,-NoahmpIO%nsnow+1:0) = 0.0 + do iz = NoahmpIO%isnowxy(i)+1, 0 + NoahmpIO%tsnoxy(i,iz) = NoahmpIO%tgxy(i) + NoahmpIO%snliqxy(i,iz) = 0.0 + NoahmpIO%snicexy(i,iz) = 1.0 * dzsno(iz) * (NoahmpIO%snow(i)/NoahmpIO%snowh(i)) + enddo + + ! assign local variable dzsnso, the soil/snow layer thicknesses, for snow layers + do iz = NoahmpIO%isnowxy(i)+1, 0 + dzsnso(iz) = -dzsno(iz) + enddo + + ! assign local variable dzsnso, the soil/snow layer thicknesses, for soil layers + dzsnso(1) = NoahmpIO%zsoil(1) + do iz = 2, NoahmpIO%nsoil + dzsnso(iz) = NoahmpIO%zsoil(iz) - NoahmpIO%zsoil(iz-1) + enddo + + ! assign zsnsoxy, the layer depths, for soil and snow layers + NoahmpIO%zsnsoxy(i,NoahmpIO%isnowxy(i)+1) = dzsnso(NoahmpIO%isnowxy(i)+1) + do iz = NoahmpIO%isnowxy(i)+2, NoahmpIO%nsoil + NoahmpIO%zsnsoxy(i,iz) = NoahmpIO%zsnsoxy(i,iz-1) + dzsnso(iz) + enddo + + enddo + + end subroutine NoahmpSnowInitMain + + end module NoahmpSnowInitMod + diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/PedoTransferSR2006Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/PedoTransferSR2006Mod.F90 new file mode 100644 index 0000000000..02090e82aa --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/PedoTransferSR2006Mod.F90 @@ -0,0 +1,210 @@ +module PedoTransferSR2006Mod + +!!! Compute soil water infiltration based on different soil composition + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + + subroutine PedoTransferSR2006(NoahmpIO, noahmp, Sand, Clay, Orgm) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PEDOTRANSFER_SR2006 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(NoahmpIO_type), intent(inout) :: NoahmpIO + type(noahmp_type) , intent(inout) :: noahmp + + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL), intent(inout) :: Sand + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL), intent(inout) :: Clay + real(kind=kind_noahmp), dimension(1:NoahmpIO%NSOIL), intent(inout) :: Orgm + +! local + integer :: k + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_1500t + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_1500 + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_33t + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_33 + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_s33t + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: theta_s33 + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: psi_et + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: psi_e + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcmax + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcref + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcwlt + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: smcdry + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: bexp + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: psisat + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: dksat + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: dwsat + real(kind=kind_noahmp), dimension( 1:NoahmpIO%NSOIL ) :: quartz + +! ------------------------------------------------------------------------------ + associate( & + sr2006_theta_1500t_a => NoahmpIO%sr2006_theta_1500t_a_TABLE ,& + sr2006_theta_1500t_b => NoahmpIO%sr2006_theta_1500t_b_TABLE ,& + sr2006_theta_1500t_c => NoahmpIO%sr2006_theta_1500t_c_TABLE ,& + sr2006_theta_1500t_d => NoahmpIO%sr2006_theta_1500t_d_TABLE ,& + sr2006_theta_1500t_e => NoahmpIO%sr2006_theta_1500t_e_TABLE ,& + sr2006_theta_1500t_f => NoahmpIO%sr2006_theta_1500t_f_TABLE ,& + sr2006_theta_1500t_g => NoahmpIO%sr2006_theta_1500t_g_TABLE ,& + sr2006_theta_1500_a => NoahmpIO%sr2006_theta_1500_a_TABLE ,& + sr2006_theta_1500_b => NoahmpIO%sr2006_theta_1500_b_TABLE ,& + sr2006_theta_33t_a => NoahmpIO%sr2006_theta_33t_a_TABLE ,& + sr2006_theta_33t_b => NoahmpIO%sr2006_theta_33t_b_TABLE ,& + sr2006_theta_33t_c => NoahmpIO%sr2006_theta_33t_c_TABLE ,& + sr2006_theta_33t_d => NoahmpIO%sr2006_theta_33t_d_TABLE ,& + sr2006_theta_33t_e => NoahmpIO%sr2006_theta_33t_e_TABLE ,& + sr2006_theta_33t_f => NoahmpIO%sr2006_theta_33t_f_TABLE ,& + sr2006_theta_33t_g => NoahmpIO%sr2006_theta_33t_g_TABLE ,& + sr2006_theta_33_a => NoahmpIO%sr2006_theta_33_a_TABLE ,& + sr2006_theta_33_b => NoahmpIO%sr2006_theta_33_b_TABLE ,& + sr2006_theta_33_c => NoahmpIO%sr2006_theta_33_c_TABLE ,& + sr2006_theta_s33t_a => NoahmpIO%sr2006_theta_s33t_a_TABLE ,& + sr2006_theta_s33t_b => NoahmpIO%sr2006_theta_s33t_b_TABLE ,& + sr2006_theta_s33t_c => NoahmpIO%sr2006_theta_s33t_c_TABLE ,& + sr2006_theta_s33t_d => NoahmpIO%sr2006_theta_s33t_d_TABLE ,& + sr2006_theta_s33t_e => NoahmpIO%sr2006_theta_s33t_e_TABLE ,& + sr2006_theta_s33t_f => NoahmpIO%sr2006_theta_s33t_f_TABLE ,& + sr2006_theta_s33t_g => NoahmpIO%sr2006_theta_s33t_g_TABLE ,& + sr2006_theta_s33_a => NoahmpIO%sr2006_theta_s33_a_TABLE ,& + sr2006_theta_s33_b => NoahmpIO%sr2006_theta_s33_b_TABLE ,& + sr2006_psi_et_a => NoahmpIO%sr2006_psi_et_a_TABLE ,& + sr2006_psi_et_b => NoahmpIO%sr2006_psi_et_b_TABLE ,& + sr2006_psi_et_c => NoahmpIO%sr2006_psi_et_c_TABLE ,& + sr2006_psi_et_d => NoahmpIO%sr2006_psi_et_d_TABLE ,& + sr2006_psi_et_e => NoahmpIO%sr2006_psi_et_e_TABLE ,& + sr2006_psi_et_f => NoahmpIO%sr2006_psi_et_f_TABLE ,& + sr2006_psi_et_g => NoahmpIO%sr2006_psi_et_g_TABLE ,& + sr2006_psi_e_a => NoahmpIO%sr2006_psi_e_a_TABLE ,& + sr2006_psi_e_b => NoahmpIO%sr2006_psi_e_b_TABLE ,& + sr2006_psi_e_c => NoahmpIO%sr2006_psi_e_c_TABLE ,& + sr2006_smcmax_a => NoahmpIO%sr2006_smcmax_a_TABLE ,& + sr2006_smcmax_b => NoahmpIO%sr2006_smcmax_b_TABLE & + ) +! ------------------------------------------------------------------------------- + + ! initialize + smcmax = 0.0 + smcref = 0.0 + smcwlt = 0.0 + smcdry = 0.0 + bexp = 0.0 + psisat = 0.0 + dksat = 0.0 + dwsat = 0.0 + quartz = 0.0 + + do k = 1,4 + if(Sand(k) <= 0 .or. Clay(k) <= 0) then + Sand(k) = 0.41 + Clay(k) = 0.18 + end if + if(Orgm(k) <= 0 ) Orgm(k) = 0.0 + end do + + ! compute soil properties + theta_1500t = sr2006_theta_1500t_a*Sand & + + sr2006_theta_1500t_b*Clay & + + sr2006_theta_1500t_c*Orgm & + + sr2006_theta_1500t_d*Sand*Orgm & + + sr2006_theta_1500t_e*Clay*Orgm & + + sr2006_theta_1500t_f*Sand*Clay & + + sr2006_theta_1500t_g + + theta_1500 = theta_1500t & + + sr2006_theta_1500_a*theta_1500t & + + sr2006_theta_1500_b + + theta_33t = sr2006_theta_33t_a*Sand & + + sr2006_theta_33t_b*Clay & + + sr2006_theta_33t_c*Orgm & + + sr2006_theta_33t_d*Sand*Orgm & + + sr2006_theta_33t_e*Clay*Orgm & + + sr2006_theta_33t_f*Sand*Clay & + + sr2006_theta_33t_g + + theta_33 = theta_33t & + + sr2006_theta_33_a*theta_33t*theta_33t & + + sr2006_theta_33_b*theta_33t & + + sr2006_theta_33_c + + theta_s33t = sr2006_theta_s33t_a*Sand & + + sr2006_theta_s33t_b*Clay & + + sr2006_theta_s33t_c*Orgm & + + sr2006_theta_s33t_d*Sand*Orgm & + + sr2006_theta_s33t_e*Clay*Orgm & + + sr2006_theta_s33t_f*Sand*Clay & + + sr2006_theta_s33t_g + + theta_s33 = theta_s33t & + + sr2006_theta_s33_a*theta_s33t & + + sr2006_theta_s33_b + + psi_et = sr2006_psi_et_a*Sand & + + sr2006_psi_et_b*Clay & + + sr2006_psi_et_c*theta_s33 & + + sr2006_psi_et_d*Sand*theta_s33 & + + sr2006_psi_et_e*Clay*theta_s33 & + + sr2006_psi_et_f*Sand*Clay & + + sr2006_psi_et_g + + psi_e = psi_et & + + sr2006_psi_e_a*psi_et*psi_et & + + sr2006_psi_e_b*psi_et & + + sr2006_psi_e_c + + ! assign property values + smcwlt = theta_1500 + smcref = theta_33 + smcmax = theta_33 & + + theta_s33 & + + sr2006_smcmax_a*Sand & + + sr2006_smcmax_b + + bexp = 3.816712826 / (log(theta_33) - log(theta_1500) ) + psisat = psi_e + dksat = 1930.0 * (smcmax - theta_33) ** (3.0 - 1.0/bexp) + quartz = Sand + + ! Units conversion + psisat = max(0.1, psisat) ! arbitrarily impose a limit of 0.1kpa + psisat = 0.101997 * psisat ! convert kpa to m + dksat = dksat / 3600000.0 ! convert mm/h to m/s + dwsat = dksat * psisat * bexp / smcmax ! units should be m*m/s + smcdry = smcwlt + + ! Introducing somewhat arbitrary limits (based on NoahmpTable soil) to prevent bad things + smcmax = max(0.32 ,min(smcmax, 0.50 )) + smcref = max(0.17 ,min(smcref, smcmax)) + smcwlt = max(0.01 ,min(smcwlt, smcref)) + smcdry = max(0.01 ,min(smcdry, smcref)) + bexp = max(2.50 ,min(bexp, 12.0 )) + psisat = max(0.03 ,min(psisat, 1.00 )) + dksat = max(5.e-7,min(dksat, 1.e-5)) + dwsat = max(1.e-6,min(dwsat, 3.e-5)) + quartz = max(0.05 ,min(quartz, 0.95 )) + + noahmp%water%param%SoilMoistureWilt = smcwlt + noahmp%water%param%SoilMoistureFieldCap = smcref + noahmp%water%param%SoilMoistureSat = smcmax + noahmp%water%param%SoilMoistureDry = smcdry + noahmp%water%param%SoilExpCoeffB = bexp + noahmp%water%param%SoilMatPotentialSat = psisat + noahmp%water%param%SoilWatConductivitySat = dksat + noahmp%water%param%SoilWatDiffusivitySat = dwsat + noahmp%energy%param%SoilQuartzFrac = quartz + + end associate + + end subroutine PedoTransferSR2006 + +end module PedoTransferSR2006Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarInTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarInTransferMod.F90 new file mode 100644 index 0000000000..add4dcec56 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarInTransferMod.F90 @@ -0,0 +1,241 @@ +module WaterVarInTransferMod + +!!! Transfer input 2-D NoahmpIO Water variables to 1-D column variable +!!! 1-D variables should be first defined in /src/WaterVarType.F90 +!!! 2-D variables should be first defined in NoahmpIOVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + use PedoTransferSR2006Mod + + implicit none + +contains + +!=== initialize with input data or table values + + subroutine WaterVarInTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + + ! local variables + integer :: IndexSoilLayer + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilSand + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilClay + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilOrg + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + VegType => noahmp%config%domain%VegType ,& + SoilType => noahmp%config%domain%SoilType ,& + FlagUrban => noahmp%config%domain%FlagUrban ,& + RunoffSlopeType => noahmp%config%domain%RunoffSlopeType ,& + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg & + ) +! ------------------------------------------------------------------------- + + ! water state variables + noahmp%water%state%CanopyLiqWater = NoahmpIO%CANLIQXY (I) + noahmp%water%state%CanopyIce = NoahmpIO%CANICEXY (I) + noahmp%water%state%CanopyWetFrac = NoahmpIO%FWETXY (I) + noahmp%water%state%SnowWaterEquiv = NoahmpIO%SNOW (I) + noahmp%water%state%SnowWaterEquivPrev = NoahmpIO%SNEQVOXY (I) + noahmp%water%state%SnowDepth = NoahmpIO%SNOWH (I) + noahmp%water%state%IrrigationFracFlood = NoahmpIO%FIFRACT (I) + noahmp%water%state%IrrigationAmtFlood = NoahmpIO%IRWATFI (I) + noahmp%water%state%IrrigationFracMicro = NoahmpIO%MIFRACT (I) + noahmp%water%state%IrrigationAmtMicro = NoahmpIO%IRWATMI (I) + noahmp%water%state%IrrigationFracSprinkler = NoahmpIO%SIFRACT (I) + noahmp%water%state%IrrigationAmtSprinkler = NoahmpIO%IRWATSI (I) + noahmp%water%state%WaterTableDepth = NoahmpIO%ZWTXY (I) + noahmp%water%state%SoilMoistureToWT = NoahmpIO%SMCWTDXY (I) + noahmp%water%state%TileDrainFrac = NoahmpIO%TD_FRACTION(I) + noahmp%water%state%WaterStorageAquifer = NoahmpIO%WAXY (I) + noahmp%water%state%WaterStorageSoilAqf = NoahmpIO%WTXY (I) + noahmp%water%state%WaterStorageLake = NoahmpIO%WSLAKEXY (I) + noahmp%water%state%IrrigationFracGrid = NoahmpIO%IRFRACT (I) + noahmp%water%state%IrrigationCntSprinkler = NoahmpIO%IRNUMSI (I) + noahmp%water%state%IrrigationCntMicro = NoahmpIO%IRNUMMI (I) + noahmp%water%state%IrrigationCntFlood = NoahmpIO%IRNUMFI (I) + noahmp%water%state%SnowIce (-NumSnowLayerMax+1:0) = NoahmpIO%SNICEXY (I,-NumSnowLayerMax+1:0) + noahmp%water%state%SnowLiqWater(-NumSnowLayerMax+1:0) = NoahmpIO%SNLIQXY (I,-NumSnowLayerMax+1:0) + noahmp%water%state%SoilLiqWater (1:NumSoilLayer) = NoahmpIO%SH2O (I,1:NumSoilLayer) + noahmp%water%state%SoilMoisture (1:NumSoilLayer) = NoahmpIO%SMOIS (I,1:NumSoilLayer) + noahmp%water%state%SoilMoistureEqui (1:NumSoilLayer) = NoahmpIO%SMOISEQ (I,1:NumSoilLayer) + noahmp%water%state%RechargeGwDeepWT = 0.0 + noahmp%water%state%RechargeGwShallowWT = 0.0 +#ifdef WRF_HYDRO + noahmp%water%state%WaterTableHydro = NoahmpIO%ZWATBLE2D (I) + noahmp%water%state%WaterHeadSfc = NoahmpIO%sfcheadrt (I) +#endif + + ! water flux variables + noahmp%water%flux%EvapSoilSfcLiqAcc = NoahmpIO%ACC_QSEVAXY (I) + noahmp%water%flux%SoilSfcInflowAcc = NoahmpIO%ACC_QINSURXY(I) + noahmp%water%flux%SfcWaterTotChgAcc = NoahmpIO%ACC_DWATERXY(I) + noahmp%water%flux%PrecipTotAcc = NoahmpIO%ACC_PRCPXY (I) + noahmp%water%flux%EvapCanopyNetAcc = NoahmpIO%ACC_ECANXY (I) + noahmp%water%flux%TranspirationAcc = NoahmpIO%ACC_ETRANXY (I) + noahmp%water%flux%EvapGroundNetAcc = NoahmpIO%ACC_EDIRXY (I) + noahmp%water%flux%TranspWatLossSoilAcc(1:NumSoilLayer)= NoahmpIO%ACC_ETRANIXY(I,1:NumSoilLayer) + + ! water parameter variables + noahmp%water%param%DrainSoilLayerInd = NoahmpIO%DRAIN_LAYER_OPT_TABLE + noahmp%water%param%CanopyLiqHoldCap = NoahmpIO%CH2OP_TABLE(VegType) + noahmp%water%param%SnowCompactBurdenFac = NoahmpIO%C2_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingFac1 = NoahmpIO%C3_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingFac2 = NoahmpIO%C4_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingFac3 = NoahmpIO%C5_SNOWCOMPACT_TABLE + noahmp%water%param%SnowCompactAgingMax = NoahmpIO%DM_SNOWCOMPACT_TABLE + noahmp%water%param%SnowViscosityCoeff = NoahmpIO%ETA0_SNOWCOMPACT_TABLE + noahmp%water%param%SnowLiqFracMax = NoahmpIO%SNLIQMAXFRAC_TABLE + noahmp%water%param%SnowLiqHoldCap = NoahmpIO%SSI_TABLE + noahmp%water%param%SnowLiqReleaseFac = NoahmpIO%SNOW_RET_FAC_TABLE + noahmp%water%param%IrriFloodRateFac = NoahmpIO%FIRTFAC_TABLE + noahmp%water%param%IrriMicroRate = NoahmpIO%MICIR_RATE_TABLE + noahmp%water%param%SoilConductivityRef = NoahmpIO%REFDK_TABLE + noahmp%water%param%SoilInfilFacRef = NoahmpIO%REFKDT_TABLE + noahmp%water%param%GroundFrzCoeff = NoahmpIO%FRZK_TABLE + noahmp%water%param%GridTopoIndex = NoahmpIO%TIMEAN_TABLE + noahmp%water%param%SoilSfcSatFracMax = NoahmpIO%FSATMX_TABLE + noahmp%water%param%SpecYieldGw = NoahmpIO%ROUS_TABLE + noahmp%water%param%MicroPoreContent = NoahmpIO%CMIC_TABLE + noahmp%water%param%WaterStorageLakeMax = NoahmpIO%WSLMAX_TABLE + noahmp%water%param%SnoWatEqvMaxGlacier = NoahmpIO%SWEMAXGLA_TABLE + noahmp%water%param%IrriStopDayBfHarvest = NoahmpIO%IRR_HAR_TABLE + noahmp%water%param%IrriTriggerLaiMin = NoahmpIO%IRR_LAI_TABLE + noahmp%water%param%SoilWatDeficitAllow = NoahmpIO%IRR_MAD_TABLE + noahmp%water%param%IrriFloodLossFrac = NoahmpIO%FILOSS_TABLE + noahmp%water%param%IrriSprinklerRate = NoahmpIO%SPRIR_RATE_TABLE + noahmp%water%param%IrriFracThreshold = NoahmpIO%IRR_FRAC_TABLE + noahmp%water%param%IrriStopPrecipThr = NoahmpIO%IR_RAIN_TABLE + noahmp%water%param%SnowfallDensityMax = NoahmpIO%SNOWDEN_MAX_TABLE + noahmp%water%param%SnowMassFullCoverOld = NoahmpIO%SWEMX_TABLE + noahmp%water%param%SoilMatPotentialWilt = NoahmpIO%PSIWLT_TABLE + noahmp%water%param%SnowMeltFac = NoahmpIO%MFSNO_TABLE(VegType) + noahmp%water%param%SnowCoverFac = NoahmpIO%SCFFAC_TABLE(VegType) + noahmp%water%param%InfilFacVic = NoahmpIO%BVIC_TABLE(SoilType(1)) + noahmp%water%param%TensionWatDistrInfl = NoahmpIO%AXAJ_TABLE(SoilType(1)) + noahmp%water%param%TensionWatDistrShp = NoahmpIO%BXAJ_TABLE(SoilType(1)) + noahmp%water%param%FreeWatDistrShp = NoahmpIO%XXAJ_TABLE(SoilType(1)) + noahmp%water%param%InfilHeteroDynVic = NoahmpIO%BBVIC_TABLE(SoilType(1)) + noahmp%water%param%InfilCapillaryDynVic = NoahmpIO%GDVIC_TABLE(SoilType(1)) + noahmp%water%param%InfilFacDynVic = NoahmpIO%BDVIC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainCoeffSp = NoahmpIO%TD_DC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainTubeDepth = NoahmpIO%TD_DEPTH_TABLE(SoilType(1)) + noahmp%water%param%DrainFacSoilWat = NoahmpIO%TDSMC_FAC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainCoeff = NoahmpIO%TD_DCOEF_TABLE(SoilType(1)) + noahmp%water%param%DrainDepthToImperv = NoahmpIO%TD_ADEPTH_TABLE(SoilType(1)) + noahmp%water%param%LateralWatCondFac = NoahmpIO%KLAT_FAC_TABLE(SoilType(1)) + noahmp%water%param%TileDrainDepth = NoahmpIO%TD_DDRAIN_TABLE(SoilType(1)) + noahmp%water%param%DrainTubeDist = NoahmpIO%TD_SPAC_TABLE(SoilType(1)) + noahmp%water%param%DrainTubeRadius = NoahmpIO%TD_RADI_TABLE(SoilType(1)) + noahmp%water%param%DrainWatDepToImperv = NoahmpIO%TD_D_TABLE(SoilType(1)) + noahmp%water%param%NumSoilLayerRoot = NoahmpIO%NROOT_TABLE(VegType) + noahmp%water%param%SoilDrainSlope = NoahmpIO%SLOPE_TABLE(RunoffSlopeType) + + do IndexSoilLayer = 1, size(SoilType) + noahmp%water%param%SoilMoistureSat (IndexSoilLayer) = NoahmpIO%SMCMAX_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMoistureWilt (IndexSoilLayer) = NoahmpIO%SMCWLT_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMoistureFieldCap (IndexSoilLayer) = NoahmpIO%SMCREF_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMoistureDry (IndexSoilLayer) = NoahmpIO%SMCDRY_TABLE(SoilType(IndexSoilLayer)) + noahmp%water%param%SoilWatDiffusivitySat (IndexSoilLayer) = NoahmpIO%DWSAT_TABLE (SoilType(IndexSoilLayer)) + noahmp%water%param%SoilWatConductivitySat(IndexSoilLayer) = NoahmpIO%DKSAT_TABLE (SoilType(IndexSoilLayer)) + noahmp%water%param%SoilExpCoeffB (IndexSoilLayer) = NoahmpIO%BEXP_TABLE (SoilType(IndexSoilLayer)) + noahmp%water%param%SoilMatPotentialSat (IndexSoilLayer) = NoahmpIO%PSISAT_TABLE(SoilType(IndexSoilLayer)) + enddo + + ! spatial varying soil texture and properties directly from input + if ( noahmp%config%nmlist%OptSoilProperty == 4 ) then + ! 3D soil properties + noahmp%water%param%SoilExpCoeffB = NoahmpIO%BEXP_3D (I,1:NumSoilLayer) ! C-H B exponent + noahmp%water%param%SoilMoistureDry = NoahmpIO%SMCDRY_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Dry + noahmp%water%param%SoilMoistureWilt = NoahmpIO%SMCWLT_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Wilt + noahmp%water%param%SoilMoistureFieldCap = NoahmpIO%SMCREF_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Reference + noahmp%water%param%SoilMoistureSat = NoahmpIO%SMCMAX_3D(I,1:NumSoilLayer) ! Soil Moisture Limit: Max + noahmp%water%param%SoilWatConductivitySat = NoahmpIO%DKSAT_3D (I,1:NumSoilLayer) ! Saturated Soil Conductivity + noahmp%water%param%SoilWatDiffusivitySat = NoahmpIO%DWSAT_3D (I,1:NumSoilLayer) ! Saturated Soil Diffusivity + noahmp%water%param%SoilMatPotentialSat = NoahmpIO%PSISAT_3D(I,1:NumSoilLayer) ! Saturated Matric Potential + noahmp%water%param%SoilConductivityRef = NoahmpIO%REFDK_2D (I) ! Reference Soil Conductivity + noahmp%water%param%SoilInfilFacRef = NoahmpIO%REFKDT_2D(I) ! Soil Infiltration Parameter + ! 2D additional runoff6~8 parameters + noahmp%water%param%InfilFacVic = NoahmpIO%BVIC_2D (I) ! VIC model infiltration parameter + noahmp%water%param%TensionWatDistrInfl = NoahmpIO%AXAJ_2D (I) ! Xinanjiang: Tension water distribution inflection parameter + noahmp%water%param%TensionWatDistrShp = NoahmpIO%BXAJ_2D (I) ! Xinanjiang: Tension water distribution shape parameter + noahmp%water%param%FreeWatDistrShp = NoahmpIO%XXAJ_2D (I) ! Xinanjiang: Free water distribution shape parameter + noahmp%water%param%InfilFacDynVic = NoahmpIO%BDVIC_2D(I) ! VIC model infiltration parameter + noahmp%water%param%InfilCapillaryDynVic = NoahmpIO%GDVIC_2D(I) ! Mean Capillary Drive for infiltration models + noahmp%water%param%InfilHeteroDynVic = NoahmpIO%BBVIC_2D(I) ! DVIC heterogeniety parameter for infiltraton + ! 2D irrigation params + noahmp%water%param%IrriFracThreshold = NoahmpIO%IRR_FRAC_2D (I) ! irrigation Fraction + noahmp%water%param%IrriStopDayBfHarvest = NoahmpIO%IRR_HAR_2D (I) ! number of days before harvest date to stop irrigation + noahmp%water%param%IrriTriggerLaiMin = NoahmpIO%IRR_LAI_2D (I) ! Minimum lai to trigger irrigation + noahmp%water%param%SoilWatDeficitAllow = NoahmpIO%IRR_MAD_2D (I) ! management allowable deficit (0-1) + noahmp%water%param%IrriFloodLossFrac = NoahmpIO%FILOSS_2D (I) ! fraction of flood irrigation loss (0-1) + noahmp%water%param%IrriSprinklerRate = NoahmpIO%SPRIR_RATE_2D(I) ! mm/h, sprinkler irrigation rate + noahmp%water%param%IrriMicroRate = NoahmpIO%MICIR_RATE_2D(I) ! mm/h, micro irrigation rate + noahmp%water%param%IrriFloodRateFac = NoahmpIO%FIRTFAC_2D (I) ! flood application rate factor + noahmp%water%param%IrriStopPrecipThr = NoahmpIO%IR_RAIN_2D (I) ! maximum precipitation to stop irrigation trigger + ! 2D tile drainage parameters + noahmp%water%param%LateralWatCondFac = NoahmpIO%KLAT_FAC (I) ! factor multiplier to hydraulic conductivity + noahmp%water%param%DrainFacSoilWat = NoahmpIO%TDSMC_FAC(I) ! factor multiplier to field capacity + noahmp%water%param%TileDrainCoeffSp = NoahmpIO%TD_DC (I) ! drainage coefficient for simple + noahmp%water%param%TileDrainCoeff = NoahmpIO%TD_DCOEF (I) ! drainge coefficient for Hooghoudt + noahmp%water%param%TileDrainDepth = NoahmpIO%TD_DDRAIN(I) ! depth of drain + noahmp%water%param%DrainTubeRadius = NoahmpIO%TD_RADI (I) ! tile tube radius + noahmp%water%param%DrainTubeDist = NoahmpIO%TD_SPAC (I) ! tile spacing + endif + + ! derived water parameters + noahmp%water%param%SoilInfilMaxCoeff = noahmp%water%param%SoilInfilFacRef * & + noahmp%water%param%SoilWatConductivitySat(1) / & + noahmp%water%param%SoilConductivityRef + if ( FlagUrban .eqv. .true. ) then + noahmp%water%param%SoilMoistureSat = 0.45 + noahmp%water%param%SoilMoistureFieldCap = 0.42 + noahmp%water%param%SoilMoistureWilt = 0.40 + noahmp%water%param%SoilMoistureDry = 0.40 + endif + + if ( SoilType(1) /= 14 ) then + noahmp%water%param%SoilImpervFracCoeff = noahmp%water%param%GroundFrzCoeff * & + ((noahmp%water%param%SoilMoistureSat(1) / & + noahmp%water%param%SoilMoistureFieldCap(1)) * (0.412/0.468)) + endif + + noahmp%water%state%SnowIceFracPrev = 0.0 + noahmp%water%state%SnowIceFracPrev(NumSnowLayerNeg+1:0) = NoahmpIO%SNICEXY(I,NumSnowLayerNeg+1:0) / & + (NoahmpIO%SNICEXY(I,NumSnowLayerNeg+1:0) + & + NoahmpIO%SNLIQXY(I,NumSnowLayerNeg+1:0)) + + if ( (noahmp%config%nmlist%OptSoilProperty == 3) .and. (.not. noahmp%config%domain%FlagUrban) ) then + if (.not. allocated(SoilSand)) allocate( SoilSand(1:NumSoilLayer) ) + if (.not. allocated(SoilClay)) allocate( SoilClay(1:NumSoilLayer) ) + if (.not. allocated(SoilOrg) ) allocate( SoilOrg (1:NumSoilLayer) ) + SoilSand = 0.01 * NoahmpIO%soilcomp(I,1:NumSoilLayer) + SoilClay = 0.01 * NoahmpIO%soilcomp(I,(NumSoilLayer+1):(NumSoilLayer*2)) + SoilOrg = 0.0 + if (noahmp%config%nmlist%OptPedotransfer == 1) & + call PedoTransferSR2006(NoahmpIO,noahmp,SoilSand,SoilClay,SoilOrg) + deallocate(SoilSand) + deallocate(SoilClay) + deallocate(SoilOrg ) + endif + + end associate + + end subroutine WaterVarInTransfer + +end module WaterVarInTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarOutTransferMod.F90 b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarOutTransferMod.F90 new file mode 100644 index 0000000000..feaa7e996b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/drivers/mpas/WaterVarOutTransferMod.F90 @@ -0,0 +1,153 @@ +module WaterVarOutTransferMod + +!!! Transfer column (1-D) Noah-MP water variables to 2D NoahmpIO for output + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpIOVarType + use NoahmpVarType + + implicit none + +contains + +!=== Transfer model states to output ===== + + subroutine WaterVarOutTransfer(noahmp, NoahmpIO) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + type(NoahmpIO_type), intent(inout) :: NoahmpIO + +! ------------------------------------------------------------------------- + associate( & + I => noahmp%config%domain%GridIndexI ,& + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + IndicatorIceSfc => noahmp%config%domain%IndicatorIceSfc & + ) +! ------------------------------------------------------------------------- + + ! special treatment for glacier point output + if ( IndicatorIceSfc == -1 ) then ! land ice point + noahmp%water%state%SnowCoverFrac = 1.0 + noahmp%water%flux%EvapCanopyNet = 0.0 + noahmp%water%flux%Transpiration = 0.0 + noahmp%water%flux%InterceptCanopySnow = 0.0 + noahmp%water%flux%InterceptCanopyRain = 0.0 + noahmp%water%flux%DripCanopySnow = 0.0 + noahmp%water%flux%DripCanopyRain = 0.0 + noahmp%water%flux%ThroughfallSnow = noahmp%water%flux%SnowfallRefHeight + noahmp%water%flux%ThroughfallRain = noahmp%water%flux%RainfallRefHeight + noahmp%water%flux%SublimCanopyIce = 0.0 + noahmp%water%flux%FrostCanopyIce = 0.0 + noahmp%water%flux%FreezeCanopyLiq = 0.0 + noahmp%water%flux%MeltCanopyIce = 0.0 + noahmp%water%flux%EvapCanopyLiq = 0.0 + noahmp%water%flux%DewCanopyLiq = 0.0 + noahmp%water%state%CanopyIce = 0.0 + noahmp%water%state%CanopyLiqWater = 0.0 + noahmp%water%flux%TileDrain = 0.0 + noahmp%water%flux%RunoffSurface = noahmp%water%flux%RunoffSurface * noahmp%config%domain%MainTimeStep + noahmp%water%flux%RunoffSubsurface = noahmp%water%flux%RunoffSubsurface * noahmp%config%domain%MainTimeStep + NoahmpIO%QFX(I) = noahmp%water%flux%EvapGroundNet + endif + + if ( IndicatorIceSfc == 0 ) then ! land soil point + NoahmpIO%QFX(I) = noahmp%water%flux%EvapCanopyNet + noahmp%water%flux%EvapGroundNet + & + noahmp%water%flux%Transpiration + noahmp%water%flux%EvapIrriSprinkler + endif + + NoahmpIO%SMSTAV (I) = 0.0 ! [maintained as Noah consistency] water + NoahmpIO%SMSTOT (I) = 0.0 ! [maintained as Noah consistency] water + NoahmpIO%SFCRUNOFF (I) = NoahmpIO%SFCRUNOFF(I) + noahmp%water%flux%RunoffSurface + NoahmpIO%UDRUNOFF (I) = NoahmpIO%UDRUNOFF (I) + noahmp%water%flux%RunoffSubsurface + NoahmpIO%QTDRAIN (I) = NoahmpIO%QTDRAIN (I) + noahmp%water%flux%TileDrain + NoahmpIO%SNOWC (I) = noahmp%water%state%SnowCoverFrac + NoahmpIO%SNOW (I) = noahmp%water%state%SnowWaterEquiv + NoahmpIO%SNOWH (I) = noahmp%water%state%SnowDepth + NoahmpIO%CANWAT (I) = noahmp%water%state%CanopyLiqWater + noahmp%water%state%CanopyIce + NoahmpIO%ACSNOW (I) = NoahmpIO%ACSNOW(I) + (NoahmpIO%RAINBL (I) * noahmp%water%state%FrozenPrecipFrac) + NoahmpIO%ACSNOM (I) = NoahmpIO%ACSNOM(I) + (noahmp%water%flux%MeltGroundSnow * NoahmpIO%DTBL) + & + noahmp%water%state%PondSfcThinSnwMelt + noahmp%water%state%PondSfcThinSnwComb + & + noahmp%water%state%PondSfcThinSnwTrans + NoahmpIO%CANLIQXY (I) = noahmp%water%state%CanopyLiqWater + NoahmpIO%CANICEXY (I) = noahmp%water%state%CanopyIce + NoahmpIO%FWETXY (I) = noahmp%water%state%CanopyWetFrac + NoahmpIO%SNEQVOXY (I) = noahmp%water%state%SnowWaterEquivPrev + NoahmpIO%QSNOWXY (I) = noahmp%water%flux%SnowfallGround + NoahmpIO%QRAINXY (I) = noahmp%water%flux%RainfallGround + NoahmpIO%WSLAKEXY (I) = noahmp%water%state%WaterStorageLake + NoahmpIO%ZWTXY (I) = noahmp%water%state%WaterTableDepth + NoahmpIO%WAXY (I) = noahmp%water%state%WaterStorageAquifer + NoahmpIO%WTXY (I) = noahmp%water%state%WaterStorageSoilAqf + NoahmpIO%RUNSFXY (I) = noahmp%water%flux%RunoffSurface + NoahmpIO%RUNSBXY (I) = noahmp%water%flux%RunoffSubsurface + NoahmpIO%ECANXY (I) = noahmp%water%flux%EvapCanopyNet + NoahmpIO%EDIRXY (I) = noahmp%water%flux%EvapGroundNet + NoahmpIO%ETRANXY (I) = noahmp%water%flux%Transpiration + NoahmpIO%QINTSXY (I) = noahmp%water%flux%InterceptCanopySnow + NoahmpIO%QINTRXY (I) = noahmp%water%flux%InterceptCanopyRain + NoahmpIO%QDRIPSXY (I) = noahmp%water%flux%DripCanopySnow + NoahmpIO%QDRIPRXY (I) = noahmp%water%flux%DripCanopyRain + NoahmpIO%QTHROSXY (I) = noahmp%water%flux%ThroughfallSnow + NoahmpIO%QTHRORXY (I) = noahmp%water%flux%ThroughfallRain + NoahmpIO%QSNSUBXY (I) = noahmp%water%flux%SublimSnowSfcIce + NoahmpIO%QSNFROXY (I) = noahmp%water%flux%FrostSnowSfcIce + NoahmpIO%QSUBCXY (I) = noahmp%water%flux%SublimCanopyIce + NoahmpIO%QFROCXY (I) = noahmp%water%flux%FrostCanopyIce + NoahmpIO%QEVACXY (I) = noahmp%water%flux%EvapCanopyLiq + NoahmpIO%QDEWCXY (I) = noahmp%water%flux%DewCanopyLiq + NoahmpIO%QFRZCXY (I) = noahmp%water%flux%FreezeCanopyLiq + NoahmpIO%QMELTCXY (I) = noahmp%water%flux%MeltCanopyIce + NoahmpIO%QSNBOTXY (I) = noahmp%water%flux%SnowBotOutflow + NoahmpIO%QMELTXY (I) = noahmp%water%flux%MeltGroundSnow + NoahmpIO%PONDINGXY (I) = noahmp%water%state%PondSfcThinSnwTrans + & + noahmp%water%state%PondSfcThinSnwComb + noahmp%water%state%PondSfcThinSnwMelt + NoahmpIO%FPICEXY (I) = noahmp%water%state%FrozenPrecipFrac + NoahmpIO%RAINLSM (I) = noahmp%water%flux%RainfallRefHeight + NoahmpIO%SNOWLSM (I) = noahmp%water%flux%SnowfallRefHeight + NoahmpIO%ACC_QINSURXY(I) = noahmp%water%flux%SoilSfcInflowAcc + NoahmpIO%ACC_QSEVAXY (I) = noahmp%water%flux%EvapSoilSfcLiqAcc + NoahmpIO%ACC_DWATERXY(I) = noahmp%water%flux%SfcWaterTotChgAcc + NoahmpIO%ACC_PRCPXY (I) = noahmp%water%flux%PrecipTotAcc + NoahmpIO%ACC_ECANXY (I) = noahmp%water%flux%EvapCanopyNetAcc + NoahmpIO%ACC_ETRANXY (I) = noahmp%water%flux%TranspirationAcc + NoahmpIO%ACC_EDIRXY (I) = noahmp%water%flux%EvapGroundNetAcc + NoahmpIO%RECHXY (I) = NoahmpIO%RECHXY(I) + (noahmp%water%state%RechargeGwShallowWT*1.0e3) + NoahmpIO%DEEPRECHXY (I) = NoahmpIO%DEEPRECHXY(I) + noahmp%water%state%RechargeGwDeepWT + NoahmpIO%SMCWTDXY (I) = noahmp%water%state%SoilMoistureToWT + NoahmpIO%SMOIS (I,1:NumSoilLayer) = noahmp%water%state%SoilMoisture(1:NumSoilLayer) + NoahmpIO%SH2O (I,1:NumSoilLayer) = noahmp%water%state%SoilLiqWater(1:NumSoilLayer) + NoahmpIO%ACC_ETRANIXY(I,1:NumSoilLayer) = noahmp%water%flux%TranspWatLossSoilAcc(1:NumSoilLayer) + NoahmpIO%SNICEXY (I,-NumSnowLayerMax+1:0) = noahmp%water%state%SnowIce(-NumSnowLayerMax+1:0) + NoahmpIO%SNLIQXY (I,-NumSnowLayerMax+1:0) = noahmp%water%state%SnowLiqWater(-NumSnowLayerMax+1:0) + + ! irrigation + NoahmpIO%IRNUMSI (I) = noahmp%water%state%IrrigationCntSprinkler + NoahmpIO%IRNUMMI (I) = noahmp%water%state%IrrigationCntMicro + NoahmpIO%IRNUMFI (I) = noahmp%water%state%IrrigationCntFlood + NoahmpIO%IRWATSI (I) = noahmp%water%state%IrrigationAmtSprinkler + NoahmpIO%IRWATMI (I) = noahmp%water%state%IrrigationAmtMicro + NoahmpIO%IRWATFI (I) = noahmp%water%state%IrrigationAmtFlood + NoahmpIO%IRSIVOL (I) = NoahmpIO%IRSIVOL(I)+(noahmp%water%flux%IrrigationRateSprinkler*1000.0) + NoahmpIO%IRMIVOL (I) = NoahmpIO%IRMIVOL(I)+(noahmp%water%flux%IrrigationRateMicro*1000.0) + NoahmpIO%IRFIVOL (I) = NoahmpIO%IRFIVOL(I)+(noahmp%water%flux%IrrigationRateFlood*1000.0) + NoahmpIO%IRELOSS (I) = NoahmpIO%IRELOSS(I)+(noahmp%water%flux%EvapIrriSprinkler*NoahmpIO%DTBL) + +#ifdef WRF_HYDRO + NoahmpIO%infxsrt (I) = max(noahmp%water%flux%RunoffSurface, 0.0) ! mm, surface runoff + NoahmpIO%soldrain (I) = max(noahmp%water%flux%RunoffSubsurface, 0.0) ! mm, underground runoff + NoahmpIO%qtiledrain(I) = max(noahmp%water%flux%TileDrain, 0.0) ! mm, tile drainage +#endif + + end associate + + end subroutine WaterVarOutTransfer + +end module WaterVarOutTransferMod diff --git a/src/core_atmosphere/physics/physics_noahmp/parameters/NoahmpTable.TBL b/src/core_atmosphere/physics/physics_noahmp/parameters/NoahmpTable.TBL new file mode 100644 index 0000000000..c9d37c5b40 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/parameters/NoahmpTable.TBL @@ -0,0 +1,856 @@ +! ---------------- Noah-MP Parameter Look-up Table History ------------------------ +! Original Table: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Updated Table: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! Updated table reformats and merges original MPTABLE.TBL, SOILPARM.TBL, GENPARM.TBL +! ---------------------------------------------------------------------------------- + +&noahmp_usgs_veg_categories + VEG_DATASET_DESCRIPTION = "USGS" ! land type dataset + NVEG = 27 ! total number of land categories in USGS +/ + +&noahmp_usgs_parameters + ! NVEG = 27 + ! 1: Urban and Built-Up Land + ! 2: Dryland Cropland and Pasture + ! 3: Irrigated Cropland and Pasture + ! 4: Mixed Dryland/Irrigated Cropland and Pasture + ! 5: Cropland/Grassland Mosaic + ! 6: Cropland/Woodland Mosaic + ! 7: Grassland + ! 8: Shrubland + ! 9: Mixed Shrubland/Grassland + ! 10: Savanna + ! 11: Deciduous Broadleaf Forest + ! 12: Deciduous Needleleaf Forest + ! 13: Evergreen Broadleaf Forest + ! 14: Evergreen Needleleaf Forest + ! 15: Mixed Forest + ! 16: Water Bodies + ! 17: Herbaceous Wetland + ! 18: Wooded Wetland + ! 19: Barren or Sparsely Vegetated + ! 20: Herbaceous Tundra + ! 21: Wooded Tundra + ! 22: Mixed Tundra + ! 23: Bare Ground Tundra + ! 24: Snow or Ice + ! 25: Playa + ! 26: Lava + ! 27: White Sand + + ! specify some key land category indicators + ISURBAN = 1 ! urban land type in USGS + ISWATER = 16 ! water land type in USGS + ISBARREN = 19 ! bare soil land type in USGS + ISICE = 24 ! ice land type in USGS + ISCROP = 2 ! crop land type in USGS + EBLFOREST = 13 ! evergreen broadleaf forest land type in USGS + NATURAL = 5 ! natural vegation type in urban pixel in USGS + URBTYPE_beg = 50 ! land type number above which are urban (e.g., LCZ) + LCZ_1 = 51 ! urban local climate zone (LCZ) type 1: compact highrise + LCZ_2 = 52 ! urban local climate zone (LCZ) type 2: compact midrise + LCZ_3 = 53 ! urban local climate zone (LCZ) type 3: compact lowrise + LCZ_4 = 54 ! urban local climate zone (LCZ) type 4: open highrise + LCZ_5 = 55 ! urban local climate zone (LCZ) type 5: open midrise + LCZ_6 = 56 ! urban local climate zone (LCZ) type 6: open lowrise + LCZ_7 = 57 ! urban local climate zone (LCZ) type 7: lightweight lowrise + LCZ_8 = 58 ! urban local climate zone (LCZ) type 8: large lowrise + LCZ_9 = 59 ! urban local climate zone (LCZ) type 9: sparsely built + LCZ_10 = 60 ! urban local climate zone (LCZ) type 10: heavy industry + LCZ_11 = 61 ! urban local climate zone (LCZ) type 11: bare rock or paved + + ! start the vegetation-dependent parameters + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! VegType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! CH2OP: maximum intercepted h2o per unit lai+sai (mm) + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + ! DLEAF: characteristic leaf dimension (m) + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + ! Z0MVT: momentum roughness length (m) + Z0MVT = 1.00, 0.15, 0.15, 0.15, 0.14, 0.50, 0.12, 0.06, 0.09, 0.50, 0.80, 0.85, 1.10, 1.09, 0.80, 0.00, 0.12, 0.50, 0.00, 0.10, 0.30, 0.20, 0.03, 0.00, 0.01, 0.00, 0.00, + ! HVT: top of canopy (m) + HVT = 15.0, 2.00, 2.00, 2.00, 1.50, 8.00, 1.00, 1.10, 1.10, 10.0, 16.0, 18.0, 20.0, 20.0, 16.0, 0.00, 0.50, 10.0, 0.00, 0.50, 4.00, 2.00, 0.50, 0.00, 0.10, 0.00, 0.00, + ! HVB: bottom of canopy (m) + HVB = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + ! DEN: tree density (no. of trunks per m2) + DEN = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, + ! RC: tree crown radius (m) + RC = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, + ! MFSNO: snowmelt curve parameter, originally =2.5 everywhere, currently optimized dependent on land type based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2019 JGR) + MFSNO = 4.00, 3.00, 3.00, 3.00, 4.00, 4.00, 2.00, 2.00, 2.00, 2.00, 1.00, 1.00, 1.00, 1.00, 1.00, 3.00, 3.00, 3.00, 3.00, 3.50, 3.50, 3.50, 3.50, 2.50, 3.50, 3.50, 3.50, + ! SCFFAC: snow cover factor (m) (replace original hard-coded 2.5*z0, z0=0.002m everywhere), currently optimized based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2021 JGR) + SCFFAC = 0.042, 0.014, 0.014, 0.014, 0.026, 0.026, 0.020, 0.018, 0.016, 0.020, 0.008, 0.008, 0.008, 0.008, 0.008, 0.030, 0.020, 0.020, 0.016, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, 0.030, + ! CBIOM: canopy biomass heat capacity parameter (m), C. He 12/23/2022 bring hard-coded parameter to here + CBIOM = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + ! RHOL_VIS: leaf reflectance at visible (VIS) band + RHOL_VIS = 0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + ! RHOL_NIR: leaf reflectance at near-infra (NIR) band + RHOL_NIR = 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, + ! RHOS_VIS: stem reflectance at visible (VIS) band + RHOS_VIS = 0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, + ! RHOS_NIR: stem reflectance at near-infra (NIR) band + RHOS_NIR = 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, + ! TAUL_VIS: leaf transmittance at visible (VIS) band + TAUL_VIS = 0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, + ! TAUL_NIR: leaf transmittance at near-infra (NIR) band + TAUL_NIR = 0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, + ! TAUS_VIS: stem transmittance at visible (VIS) band + TAUS_VIS = 0.00, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + ! TAUS_NIR: stem transmittance at near-infra (NIR) band + TAUS_NIR = 0.00, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + ! XL: leaf/stem orientation index + XL = 0.000, -0.30, -0.30, -0.30, -0.30, -0.30, -0.30, 0.010, 0.250, 0.010, 0.250, 0.010, 0.010, 0.010, 0.250, 0.000, -0.30, 0.250, 0.000, -0.30, 0.250, 0.250, 0.250, 0.000, 0.250, 0.000, 0.000, + ! CWPVT: empirical canopy wind absorption parameter (J. Goudriaan, Crop Micrometeorology: A Simulation Study (Simulation monographs), 1977) + CWPVT = 0.18, 1.67, 1.67, 1.67, 1.67, 0.5, 5.0, 1.0, 2.0, 1.0, 0.67, 0.18, 0.67, 0.18, 0.29, 0.18, 1.67, 0.67, 0.18, 1.67, 0.67, 1.00, 0.18, 0.18, 0.18, 0.18, 0.18, + ! C3PSN: photosynthetic pathway: 0.0 = c4, 1.0 = c3 + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! KC25: CO2 michaelis-menten constant at 25degC (Pa) + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + ! AKC: q10 for KC25, change in CO2 Michaelis-Menten constant for every 10-degC temperature change + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + ! KO25: O2 michaelis-menten constant at 25degC (Pa) + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + ! AKO: q10 for KO25, change in O2 Michaelis-Menten constant for every 10-degC temperature change + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + ! VCMX25: maximum rate of carboxylation at 25 degC (umol CO2/m2/s) + VCMX25 = 0.00, 80.0, 80.0, 80.0, 60.0, 70.0, 40.0, 40.0, 40.0, 40.0, 60.0, 60.0, 60.0, 50.0, 55.0, 0.00, 50.0, 50.0, 0.00, 50.0, 50.0, 50.0, 50.0, 0.00, 50.0, 0.00, 0.00, + ! AVCMX: q10 for VCMX25, change in maximum rate of carboxylation at 25degC for every 10-degC temperature change + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + ! AQE: q10 for QE25, change in quantum efficiency at 25degC (umol CO2/umol photon) + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! LTOVRC: leaf turnover [1/s] + LTOVRC = 0.0, 1.2, 1.2, 1.2, 1.2, 1.30, 0.50, 0.65, 0.70, 0.65, 0.55, 0.2, 0.55, 0.5, 0.5, 0.0, 1.4, 1.4, 0.0, 1.2, 1.3, 1.4, 1.0, 0.0, 1.0, 0.0, 0.0, + ! DILEFC: coeficient for leaf stress death [1/s] + DILEFC = 0.00, 0.50, 0.50, 0.50, 0.35, 0.20, 0.20, 0.20, 0.50, 0.50, 0.60, 1.80, 0.50, 1.20, 0.80, 0.00, 0.40, 0.40, 0.00, 0.40, 0.30, 0.40, 0.30, 0.00, 0.30, 0.00, 0.00, + ! DILEFW: coeficient for leaf stress death [1/s] + DILEFW = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.20, 0.50, 0.20, 0.20, 4.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.00, 0.20, 0.20, 0.20, 0.20, 0.00, 0.20, 0.00, 0.00, + ! RMF25: leaf maintenance respiration at 25degC (umol co2/m2/s) + RMF25 = 0.00, 1.00, 1.40, 1.45, 1.45, 1.45, 1.80, 0.26, 0.26, 0.80, 3.00, 4.00, 0.65, 3.00, 3.00, 0.00, 3.20, 3.20, 0.00, 3.20, 3.00, 3.00, 3.00, 0.00, 3.00, 0.00, 0.00, + ! SLA: single-side leaf area per mass [m2/kg] + SLA = 60, 80, 80, 80, 80, 80, 60, 60, 60, 50, 80, 80, 80, 80, 80, 0, 80, 80, 0, 80, 80, 80, 80, 0, 80, 0, 0, + ! FRAGR: fraction of growth respiration + FRAGR = 0.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.10, 0.20, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + ! TMIN: minimum temperature for photosynthesis (K) + TMIN = 0, 273, 273, 273, 273, 273, 273, 273, 273, 273, 273, 268, 273, 265, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + ! TDLEF: characteristic temperature for leaf freezing [K] + TDLEF = 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 278, 268, 278, 278, 268, 0, 268, 268, 0, 268, 268, 268, 268, 0, 268, 0, 0, + ! BP: minimum leaf conductance (umol/m2/s) + BP = 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 1.E15, + ! MP: slope of conductance-to-photosynthesis relationship + MP = 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 6.0, 9.0, 6.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, + ! QE25: quantum efficiency at 25degC (umol CO2/umol photon) + QE25 = 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.00, + ! RMS25: stem maintenance respiration at 25c (umol CO2/Kg bio/s) + RMS25 = 0.00, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.10, 0.32, 0.10, 0.64, 0.30, 0.90, 0.80, 0.00, 0.10, 0.10, 0.00, 0.10, 0.10, 0.10, 0.00, 0.00, 0.00, 0.00, 0.00, + ! RMR25: root maintenance respiration at 25c (umol CO2/Kg bio/s) + RMR25 = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.20, 0.00, 0.00, 0.01, 0.01, 0.05, 0.05, 0.36, 0.03, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 2.11, 0.00, 0.00, 0.00, 0.00, 0.00, + ! ARM: q10 for maintenance respiration, change in maintenance respiration for every 10-degC temperature change + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + ! FOLNMX: foliage nitrogen concentration when f(n)=1 (%) + FOLNMX = 0.0, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.0, 0.0, + ! WDPOOL: ood pool (switch 1 or 0) depending on woody or not + WDPOOL = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, + ! WRRAT: wood to non-wood ratio + WRRAT = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 30.0, 30.0, 30.0, 30.0, 30.0, 0.00, 0.00, 30.0, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, + ! MRP: microbial respiration parameter (umol CO2/kgC/s) + MRP = 0.00, 0.23, 0.23, 0.23, 0.23, 0.23, 0.17, 0.19, 0.19, 0.40, 0.40, 0.37, 0.23, 0.37, 0.30, 0.00, 0.17, 0.40, 0.00, 0.17, 0.23, 0.20, 0.00, 0.00, 0.20, 0.00, 0.00, + ! NROOT: number of soil layers with root present + NROOT = 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 0, 2, 2, 1, 3, 3, 3, 2, 1, 1, 0, 0, + ! RGL: Parameter used in radiation stress function + RGL = 999.0, 100.0, 100.0, 100.0, 100.0, 65.0, 100.0, 100.0, 100.0, 65.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 30.0, 999.0, 100.0, 100.0, 100.0, 100.0, 999.0, 100.0, 999.0, 999.0, + ! RS: Minimum stomatal resistance (s/m) + RS = 200.0, 40.0, 40.0, 40.0, 40.0, 70.0, 40.0, 300.0, 170.0, 70.0, 100.0, 150.0, 150.0, 125.0, 125.0, 100.0, 40.0, 100.0, 999.0, 150.0, 150.0, 150.0, 200.0, 999.0, 40.0, 999.0, 999.0, + ! HS: Parameter used in vapor pressure deficit function + HS = 999.0, 36.25, 36.25, 36.25, 36.25, 44.14, 36.35, 42.00, 39.18, 54.53, 54.53, 47.35, 41.69, 47.35, 51.93, 51.75, 60.00, 51.93, 999.0, 42.00, 42.00, 42.00, 42.00, 999.0, 36.25, 999.0, 999.0, + ! TOPT: Optimum transpiration air temperature [K] + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + ! RSMAX: Maximal stomatal resistance [s/m] + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + ! RTOVRC: root turnover coefficient [1/s] + RTOVRC = 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, + ! RSWOODC: wood respiration coeficient [1/s] + RSWOODC = 3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10,3.E-10, + ! BF: parameter for present wood allocation + BF = 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + ! WSTRC: water stress coeficient + WSTRC = 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + ! LAIMIN: minimum leaf area index [m2/m2] + LAIMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! XSAMIN: minimum stem area index [m2/m2] + XSAMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! SAI: MODIS monthly climatology (2000-2008) stem area index (one row for each month) (Yang et al., 2011) + SAI_JAN = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_FEB = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_APR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAY = 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUN = 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUL = 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_AUG = 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_SEP = 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_OCT = 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_NOV = 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_DEC = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + ! LAI: MODIS monthly climatology (2000-2008) leaf area index (one row for each month) (Yang et al., 2011) + LAI_JAN = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_FEB = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAR = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_APR = 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAY = 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUN = 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUL = 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_AUG = 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_SEP = 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_OCT = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_NOV = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_DEC = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, +/ + +&noahmp_modis_veg_categories + VEG_DATASET_DESCRIPTION = "modified igbp modis noah" ! land type dataset + NVEG = 20 ! total number of land categories in MODIS (no lake) +/ + +&noahmp_modis_parameters + ! 1, 'Evergreen Needleleaf Forest' -> USGS 14 "Evergreen Needleleaf Forest" + ! 2, 'Evergreen Broadleaf Forest' -> USGS 13 "Evergreen Broadleaf Forest" + ! 3, 'Deciduous Needleleaf Forest' -> USGS 12 "Deciduous Needleleaf Forest" + ! 4, 'Deciduous Broadleaf Forest' -> USGS 11 "Deciduous Broadleaf Forest" + ! 5, 'Mixed Forests' -> USGS 15 "Mixed Forest" + ! 6, 'Closed Shrublands' -> USGS 8 "shrubland" + ! 7, 'Open Shrublands' -> USGS 9 "mixed shrubland/grassland" + ! 8, 'Woody Savannas' -> USGS 8 "shrubland" + ! 9, 'Savannas' -> USGS 10 "Savanna" + ! 10, 'Grasslands' -> USGS 7 "Grassland" + ! 11 'Permanent wetlands' -> USGS 17 & 18 mean "Herbaceous & wooded wetland" + ! 12, 'Croplands' -> USGS 2 "dryland cropland" + ! 13, 'Urban and Built-Up' -> USGS 1 "Urban and Built-Up Land" + ! 14 'cropland/natural vegetation mosaic' -> USGS 5 "Cropland/Grassland Mosaic" + ! 15, 'Snow and Ice' -> USGS 24 "Snow or Ice" + ! 16, 'Barren or Sparsely Vegetated' -> USGS 19 "Barren or Sparsely Vegetated" + ! 17, 'Water' -> USGS 16 "Water Bodies" + ! 18, 'Wooded Tundra' -> USGS 21 "Wooded Tundra" + ! 19, 'Mixed Tundra' -> USGS 22 "Mixed Tundra" + ! 20, 'Barren Tundra' -> USGS 23 "Bare Ground Tundra" + + ! specify some key land category indicators + ISURBAN = 13 ! urban land type in MODIS + ISWATER = 17 ! water land type in MODIS + ISBARREN = 16 ! bare soil land type in MODIS + ISICE = 15 ! ice land type in MODIS + ISCROP = 12 ! crop land type in MODIS + EBLFOREST = 2 ! evergreen broadleaf forest land type in MODIS + NATURAL = 14 ! natural vegation type in urban pixel in MODIS + URBTYPE_beg = 50 ! land type number above which are urban (e.g., LCZ) + LCZ_1 = 51 ! urban local climate zone (LCZ) type 1: compact highrise + LCZ_2 = 52 ! urban local climate zone (LCZ) type 2: compact midrise + LCZ_3 = 53 ! urban local climate zone (LCZ) type 3: compact lowrise + LCZ_4 = 54 ! urban local climate zone (LCZ) type 4: open highrise + LCZ_5 = 55 ! urban local climate zone (LCZ) type 5: open midrise + LCZ_6 = 56 ! urban local climate zone (LCZ) type 6: open lowrise + LCZ_7 = 57 ! urban local climate zone (LCZ) type 7: lightweight lowrise + LCZ_8 = 58 ! urban local climate zone (LCZ) type 8: large lowrise + LCZ_9 = 59 ! urban local climate zone (LCZ) type 9: sparsely built + LCZ_10 = 60 ! urban local climate zone (LCZ) type 10: heavy industry + LCZ_11 = 61 ! urban local climate zone (LCZ) type 11: bare rock or paved + + ! start the vegetation-dependent parameters + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! VegType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------- + ! CH2OP: maximum intercepted h2o per unit lai+sai (mm) + CH2OP = 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, + ! DLEAF: characteristic leaf dimension (m) + DLEAF = 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, 0.04, + ! Z0MVT: momentum roughness length (m) + Z0MVT = 1.09, 1.10, 0.85, 0.80, 0.80, 0.20, 0.06, 0.60, 0.50, 0.12, 0.30, 0.15, 1.00, 0.14, 0.00, 0.00, 0.00, 0.30, 0.20, 0.03, + ! HVT: top of canopy (m) + HVT = 20.0, 20.0, 18.0, 16.0, 16.0, 1.10, 1.10, 13.0, 10.0, 1.00, 5.00, 2.00, 15.0, 1.50, 0.00, 0.00, 0.00, 4.00, 2.00, 0.50, + ! HVB: bottom of canopy (m) + HVB = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, + ! DEN: tree density (no. of trunks per m2) + DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, + ! RC: tree crown radius (m) + RC = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, + ! MFSNO: snowmelt curve parameter, originally =2.5 everywhere, currently optimized dependent on land type based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2019 JGR) + MFSNO = 1.00, 1.00, 1.00, 1.00, 1.00, 2.00, 2.00, 2.00, 2.00, 2.00, 3.00, 3.00, 4.00, 4.00, 2.50, 3.00, 3.00, 3.50, 3.50, 3.50, + ! SCFFAC: snow cover factor (m) (replace original hard-coded 2.5*z0, z0=0.002m everywhere), currently optimized based on SNOTEL SWE & MODIS SCF, surface albedo (He et al. 2021 JGR) + SCFFAC = 0.008, 0.008, 0.008, 0.008, 0.008, 0.016, 0.016, 0.020, 0.020, 0.020, 0.020, 0.014, 0.042, 0.026, 0.030, 0.016, 0.030, 0.030, 0.030, 0.030, + ! CBIOM: canopy biomass heat capacity parameter (m), C. He 12/23/2022 bring hard-coded parameter to here + CBIOM = 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, + ! RHOL_VIS: leaf reflectance at visible (VIS) band + RHOL_VIS = 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, + ! RHOL_NIR: leaf reflectance at near-infra (NIR) band + RHOL_NIR = 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, + ! RHOS_VIS: stem reflectance at visible (VIS) band + RHOS_VIS = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, + ! RHOS_NIR: stem reflectance at near-infra (NIR) band + RHOS_NIR = 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, + ! TAUL_VIS: leaf transmittance at visible (VIS) band + TAUL_VIS = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, + ! TAUL_NIR: leaf transmittance at near-infra (NIR) band + TAUL_NIR = 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, + ! TAUS_VIS: stem transmittance at visible (VIS) band + TAUS_VIS = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + ! TAUS_NIR: stem transmittance at near-infra (NIR) band + TAUS_NIR = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + ! XL: leaf/stem orientation index + XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, + ! CWPVT: empirical canopy wind absorption parameter (J. Goudriaan, Crop Micrometeorology: A Simulation Study (Simulation monographs), 1977) + CWPVT = 0.18, 0.67, 0.18, 0.67, 0.29, 1.0, 2.0, 1.3, 1.0, 5.0, 1.17, 1.67, 1.67, 1.67, 0.18, 0.18, 0.18, 0.67, 1.0, 0.18, + ! C3PSN: photosynthetic pathway: 0.0 = c4, 1.0 = c3 + C3PSN = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! KC25: CO2 michaelis-menten constant at 25degC (Pa) + KC25 = 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, + ! AKC: q10 for KC25, change in CO2 Michaelis-Menten constant for every 10-degC temperature change + AKC = 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, 2.1, + ! KO25: O2 michaelis-menten constant at 25degC (Pa) + KO25 = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, + ! AKO: q10 for KO25, change in O2 Michaelis-Menten constant for every 10-degC temperature change + AKO = 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, 1.2, + ! AVCMX: q10 for VCMX25, change in maximum rate of carboxylation at 25degC for every 10-degC temperature change + AVCMX = 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, 2.4, + ! AQE: q10 for QE25, change in quantum efficiency at 25degC (umol CO2/umol photon) + AQE = 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, 1.0, + ! LTOVRC: leaf turnover [1/s] + LTOVRC = 0.5, 0.55, 0.2, 0.55, 0.5, 0.65, 0.65, 0.65, 0.65, 0.50, 1.4, 1.6, 0.0, 1.2, 0.0, 0.0, 0.0, 1.3, 1.4, 1.0, + ! DILEFC: coeficient for leaf stress death [1/s] + DILEFC = 1.20, 0.50, 1.80, 0.60, 0.80, 0.20, 0.20, 0.20, 0.50, 0.20, 0.4, 0.50, 0.00, 0.35, 0.00, 0.00, 0.00, 0.30, 0.40, 0.30, + ! DILEFW: coeficient for leaf stress death [1/s] + DILEFW = 0.20, 4.00, 0.20, 0.20, 0.20, 0.20, 0.20, 0.20, 0.50, 0.10, 0.2, 0.20, 0.00, 0.20, 0.00, 0.00, 0.00, 0.20, 0.20, 0.20, + ! RMF25: leaf maintenance respiration at 25degC (umol co2/m2/s) + RMF25 = 3.00, 0.65, 4.00, 3.00, 3.00, 0.26, 0.26, 0.26, 0.80, 1.80, 3.2, 1.00, 0.00, 1.45, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, + ! SLA: single-side leaf area per mass [m2/kg] + SLA = 80, 80, 80, 80, 80, 60, 60, 60, 50, 60, 80, 80, 60, 80, 0, 0, 0, 80, 80, 80, + ! FRAGR: fraction of growth respiration + FRAGR = 0.10, 0.20, 0.10, 0.20, 0.10, 0.20, 0.20, 0.20, 0.20, 0.20, 0.1, 0.20, 0.00, 0.20, 0.00, 0.10, 0.00, 0.10, 0.10, 0.10, + ! TMIN: minimum temperature for photosynthesis (K) + TMIN = 265, 273, 268, 273, 268, 273, 273, 273, 273, 273, 268, 273, 0, 273, 0, 0, 0, 268, 268, 268, + ! VCMX25: maximum rate of carboxylation at 25 degC (umol CO2/m2/s) + VCMX25 = 50.0, 60.0, 60.0, 60.0, 55.0, 40.0, 40.0, 40.0, 40.0, 40.0, 50.0, 80.0, 0.00, 60.0, 0.00, 0.00, 0.00, 50.0, 50.0, 50.0, + ! TDLEF: characteristic temperature for leaf freezing [K] + TDLEF = 278, 278, 268, 278, 268, 278, 278, 278, 278, 278, 268, 278, 278, 278, 0, 0, 0, 268, 268, 268, + ! BP: minimum leaf conductance (umol/m2/s) + BP = 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 1.E15, 2.E3, 2.E3, 2.E3, + ! MP: slope of conductance-to-photosynthesis relationship + MP = 6.0, 9.0, 6.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, 9.0, + ! QE25: quantum efficiency at 25degC (umol CO2/umol photon) + QE25 = 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.06, 0.00, 0.06, 0.00, 0.06, 0.00, 0.06, 0.06, 0.06, + ! RMS25: stem maintenance respiration at 25c (umol CO2/Kg bio/s) + RMS25 = 0.90, 0.30, 0.64, 0.10, 0.80, 0.10, 0.10, 0.10, 0.32, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, 0.00, 0.10, 0.10, 0.00, + ! RMR25: root maintenance respiration at 25c (umol CO2/Kg bio/s) + RMR25 = 0.36, 0.05, 0.05, 0.01, 0.03, 0.00, 0.00, 0.00, 0.01, 1.20, 0.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 2.11, 2.11, 0.00, + ! ARM: q10 for maintenance respiration, change in maintenance respiration for every 10-degC temperature change + ARM = 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, 2.0, + ! FOLNMX: foliage nitrogen concentration when f(n)=1 (%) + FOLNMX = 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 0.00, 1.5, 0.00, 1.5, 0.00, 1.5, 1.5, 1.5, + ! WDPOOL: ood pool (switch 1 or 0) depending on woody or not + WDPOOL = 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, + ! WRRAT: wood to non-wood ratio + WRRAT = 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 0.00, + ! MRP: microbial respiration parameter (umol CO2/kgC/s) + MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, 0.19, 0.19, 0.40, 0.17, 0.285, 0.23, 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, 0.20, 0.00, + ! NROOT: number of soil layers with root present + NROOT = 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 2, 3, 1, 3, 1, 1, 0, 3, 3, 2, + ! RGL: Parameter used in radiation stress function + RGL = 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, 100.0, 100.0, + ! RS: Minimum stomatal resistance (s/m) + RS = 125.0, 150.0, 150.0, 100.0, 125.0, 300.0, 170.0, 300.0, 70.0, 40.0, 70.0, 40.0, 200.0, 40.0, 999.0, 999.0, 100.0, 150.0, 150.0, 200.0, + ! HS: Parameter used in vapor pressure deficit function + HS = 47.35, 41.69, 47.35, 54.53, 51.93, 42.00, 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, 42.00, 42.00, + ! TOPT: Optimum transpiration air temperature [K] + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + ! RSMAX: Maximal stomatal resistance [s/m] + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., + ! RTOVRC: root turnover coefficient [1/s] + RTOVRC = 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, 2.E-8, + ! RSWOODC: wood respiration coeficient [1/s] + RSWOODC = 3.E-10,3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, 3.E-10, + ! BF: parameter for present wood allocation + BF = 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + ! WSTRC: water stress coeficient + WSTRC = 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, 100.0, + ! LAIMIN: minimum leaf area index [m2/m2] + LAIMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! XSAMIN: minimum stem area index [m2/m2] + XSAMIN = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, + ! SAI: MODIS monthly climatology (2000-2008) stem area index (one row for each month) (Yang et al., 2011) + SAI_JAN = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_FEB = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_MAR = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_APR = 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_MAY = 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_JUN = 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + SAI_JUL = 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, + SAI_AUG = 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, + SAI_SEP = 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + SAI_OCT = 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, + SAI_NOV = 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, + SAI_DEC = 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + ! LAI: MODIS monthly climatology (2000-2008) leaf area index (one row for each month) (Yang et al., 2011) + LAI_JAN = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_FEB = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_MAR = 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + LAI_APR = 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + LAI_MAY = 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, + LAI_JUN = 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + LAI_JUL = 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + LAI_AUG = 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, + LAI_SEP = 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + LAI_OCT = 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + LAI_NOV = 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_DEC = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, +/ + +&noahmp_rad_parameters + !------------------------------------------------------------------------------ + ! soil color: 1 2 3 4 5 6 7 8 soil color index for soil albedo + !------------------------------------------------------------------------------ + ALBSAT_VIS = 0.15, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05 ! saturated soil albedo at visible band + ALBSAT_NIR = 0.30, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! saturated soil albedo at NIR band + ALBDRY_VIS = 0.27, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! dry soil albedo at visible band + ALBDRY_NIR = 0.54, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20 ! dry soil albedo at NIR band + ALBICE = 0.80, 0.55 ! albedo land ice: 1=vis, 2=nir + ALBLAK = 0.60, 0.40 ! albedo frozen lakes: 1=vis, 2=nir + OMEGAS = 0.8 , 0.4 ! two-stream parameter omega for snow + BETADS = 0.5 ! two-stream parameter betad for snow + BETAIS = 0.5 ! two-stream parameter betaI for snow + EG = 0.97, 0.98 ! emissivity soil surface 1-soil;2-lake + EICE = 0.98 ! emissivity ice surface +/ + +&noahmp_global_parameters + ! atmospheric constituants + CO2 = 395.0e-06 ! CO2 partial pressure + O2 = 0.209 ! O2 partial pressure + ! runoff parameters used for SIMTOP and SIMGM + TIMEAN = 10.5 ! gridcell mean topgraphic index (global mean) + FSATMX = 0.38 ! maximum surface saturated fraction (global mean) + ROUS = 0.20 ! specific yield [-] for Niu et al. 2007 groundwater scheme (OptRunoffSubsurface=1) + CMIC = 0.80 ! microprore content (0.0-1.0), 0.0: close to free drainage + ! parameters for snow processes + SSI = 0.03 ! liquid water holding capacity for snowpack (m3/m3) + SNOW_RET_FAC = 5.0e-5 ! snowpack water release timescale factor (1/s) + SNOW_EMIS = 0.95 ! snow emissivity + SWEMX = 1.00 ! new snow mass to fully cover old snow (mm), equivalent to 10mm depth (density = 100 kg/m3) + TAU0 = 1.0e6 ! tau0 from Yang97 eqn. 10a for BATS snow aging + GRAIN_GROWTH = 5000.0 ! growth from vapor diffusion Yang97 eqn. 10b for BATS snow aging + EXTRA_GROWTH = 10.0 ! extra growth near freezing Yang97 eqn. 10c for BATS snow aging + DIRT_SOOT = 0.3 ! dirt and soot term Yang97 eqn. 10d for BATS snow aging + BATS_COSZ = 2.0 ! zenith angle snow albedo adjustment; b in Yang97 eqn. 15 for BATS snow albedo + BATS_VIS_NEW = 0.95 ! new snow visible albedo for BATS snow albedo + BATS_NIR_NEW = 0.65 ! new snow NIR albedo for BATS snow albedo + BATS_VIS_AGE = 0.2 ! age factor for diffuse visible snow albedo Yang97 eqn. 17 for BATS snow albedo + BATS_NIR_AGE = 0.5 ! age factor for diffuse NIR snow albedo Yang97 eqn. 18 for BATS snow albedo + BATS_VIS_DIR = 0.4 ! cosz factor for direct visible snow albedo Yang97 eqn. 15 for BATS snow albedo + BATS_NIR_DIR = 0.4 ! cosz factor for direct NIR snow albedo Yang97 eqn. 16 for BATS snow albedo + C2_SNOWCOMPACT = 21.0e-3 ! overburden snow compaction parameter (m3/kg) + C3_SNOWCOMPACT = 2.5e-6 ! snow desctructive metamorphism compaction parameter1 [1/s] + C4_SNOWCOMPACT = 0.04 ! snow desctructive metamorphism compaction parameter2 [1/k] + C5_SNOWCOMPACT = 2.0 ! snow desctructive metamorphism compaction parameter3 + DM_SNOWCOMPACT = 100.0 ! upper Limit on destructive metamorphism compaction [kg/m3] + ETA0_SNOWCOMPACT = 1.33e+6 ! snow viscosity coefficient [kg-s/m2], Anderson1979: 0.52e6~1.38e6; 1.33e+6 optimized based on SNOTEL obs (He et al. 2021 JGR) + SNLIQMAXFRAC = 0.4 ! maximum liquid water fraction in snow + SWEMAXGLA = 5000.0 ! Maximum SWE allowed at glaciers (mm) + SNOWDEN_MAX = 120.0 ! maximum fresh snowfall density (kg/m3) + CLASS_ALB_REF = 0.55 ! reference snow albedo in CLASS scheme + CLASS_SNO_AGE = 3600.0 ! snow aging e-folding time (s) in CLASS albedo scheme + CLASS_ALB_NEW = 0.84 ! fresh snow albedo in CLASS scheme + RSURF_SNOW = 50.0 ! surface resistence for snow [s/m] + Z0SNO = 0.002 ! snow surface roughness length (m) + ! other soil and hydrological parameters + RSURF_EXP = 5.0 ! exponent in the shape parameter for soil resistance option 1 + WSLMAX = 5000.0 ! maximum lake water storage (mm) + PSIWLT = -150.0 ! metric potential for wilting point (m) + Z0SOIL = 0.002 ! Bare-soil roughness length (m) (i.e., under the canopy) + Z0LAKE = 0.01 ! Lake surface roughness length (m) +/ + +&noahmp_irrigation_parameters + IRR_FRAC = 0.10 ! irrigation Fraction + IRR_HAR = 20 ! number of days before harvest date to stop irrigation + IRR_LAI = 0.10 ! Minimum lai to trigger irrigation + IRR_MAD = 0.60 ! management allowable deficit (0.0-1.0) + FILOSS = 0.50 ! flood irrigation loss fraction (0.0-0.99) + SPRIR_RATE = 6.40 ! mm/h, sprinkler irrigation rate + MICIR_RATE = 1.38 ! mm/h, micro irrigation rate + FIRTFAC = 1.20 ! flood application rate factor + IR_RAIN = 1.00 ! maximum precipitation [mm/hr] to stop irrigation trigger +/ + +&noahmp_crop_parameters + ! NCROP = 5 + ! 1: Corn + ! 2: Soybean + ! 3: Sorghum + ! 4: Rice + ! 5: Winter wheat + + DEFAULT_CROP = 0 ! default crop type (1-5); if =0, use generic dynamic vegetation + +!------------------------------------------------------- +! CropType: 1 2 3 4 5 +!------------------------------------------------------- + PLTDAY = 111, 131, 111, 111, 111, ! Planting date + HSDAY = 300, 280, 300, 300, 300, ! Harvest date + PLANTPOP = 78.0, 78.0, 78.0, 78.0, 78.0, ! Plant density [per ha] + GDDTBASE = 10.0, 10.0, 10.0, 10.0, 10.0, ! Base temperature for Grow Degree Day (GDD) accumulation [C] + GDDTCUT = 30.0, 30.0, 30.0, 30.0, 30.0, ! Upper temperature for Grow Degree Day (GDD) accumulation [C] + GDDS1 = 50.0, 60.0, 50.0, 50.0, 50.0, ! Grow Degree Day (GDD) from seeding to emergence + GDDS2 = 625.0, 675.0, 718.0, 718.0, 718.0, ! Grow Degree Day (GDD) from seeding to initial vegetative + GDDS3 = 933.0, 1183.0, 933.0, 933.0, 933.0, ! Grow Degree Day (GDD) from seeding to post vegetative + GDDS4 = 1103.0, 1253.0, 1103.0, 1103.0, 1103.0, ! Grow Degree Day (GDD) from seeding to intial reproductive + GDDS5 = 1555.0, 1605.0, 1555.0, 1555.0, 1555.0, ! Grow Degree Day (GDD) from seeding to pysical maturity + C3PSNI = 0.0, 1.0, 1.0, 1.0, 1.0, ! photosynthetic pathway: 0.0 = c4, 1.0 = c3; the following 11 *I parameters added by Z. Zhang, 2020/02 + KC25I = 30.0, 30.0, 30.0, 30.0, 30.0, ! CO2 michaelis-menten constant at 25 degC (pa) + AKCI = 2.1, 2.1, 2.1, 2.1, 2.1, ! q10 for KC25; change in CO2 Michaelis-Menten constant for every 10-degC temperature change + KO25I = 3.E4, 3.E4, 3.E4, 3.E4, 3.E4, ! O2 michaelis-menten constant at 25 degC (pa) + AKOI = 1.2, 1.2, 1.2, 1.2, 1.2, ! q10 for KO25; change in O2 Michaelis-Menten constant for every 10-degC temperature change + AVCMXI = 2.4, 2.4, 2.4, 2.4, 2.4, ! q10 for VCMZ25; change in maximum rate of carboxylation for every 10-degC temperature change + VCMX25I = 60.0, 80.0, 60.0, 60.0, 55.0, ! maximum rate of carboxylation at 25c (umol CO2/m2/s) + BPI = 4.E4, 1.E4, 2.E3, 2.E3, 2.E3, ! minimum leaf conductance (umol/m2/s) + MPI = 4., 9., 6., 9., 9., ! slope of conductance-to-photosynthesis relationship + FOLNMXI = 1.5, 1.5, 1.5, 1.5, 1.5, ! foliage nitrogen concentration when f(n)=1 (%) + QE25I = 0.05, 0.06, 0.06, 0.06, 0.06, ! quantum efficiency at 25 degC (umol CO2/umol photon) + Aref = 7.0, 7.0, 7.0, 7.0, 7.0, ! reference maximum CO2 assimilation rate + PSNRF = 0.85, 0.85, 0.85, 0.85, 0.85, ! CO2 assimilation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + I2PAR = 0.5, 0.5, 0.5, 0.5, 0.5, ! Fraction of incoming solar radiation to photosynthetically active radiation + TASSIM0 = 8.0, 8.0, 8.0, 8.0, 8.0, ! Minimum temperature for CO2 assimilation [C] + TASSIM1 = 18.0, 18.0, 18.0, 18.0, 18.0, ! CO2 assimilation linearly increasing until temperature reaches T1 [C] + TASSIM2 = 30.0, 30.0, 30.0, 30.0, 30.0, ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + K = 0.55, 0.55, 0.55, 0.55, 0.55, ! light extinction coefficient + EPSI = 12.5, 12.5, 12.5, 12.5, 12.5, ! initial light use efficiency + Q10MR = 2.0, 2.0, 2.0, 2.0, 2.0, ! q10 for maintainance respiration; change in maintainance respiration for every 10-degC temperature change + LEFREEZ = 268, 268, 268, 268, 268, ! characteristic T for leaf freezing [K] + DILE_FC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 1 + DILE_FC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 2 + DILE_FC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 3 + DILE_FC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 4 + DILE_FC_S5 = 0.5, 0.5, 0.5, 0.5, 0.5, ! coeficient for temperature leaf stress death [1/s] at growth stage 5 + DILE_FC_S6 = 0.5, 0.5, 0.5, 0.5, 0.5, ! coeficient for temperature leaf stress death [1/s] at growth stage 6 + DILE_FC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 7 + DILE_FC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] at growth stage 8 + DILE_FW_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 1 + DILE_FW_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 2 + DILE_FW_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 3 + DILE_FW_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 4 + DILE_FW_S5 = 0.2, 0.2, 0.2, 0.2, 0.2, ! coeficient for water leaf stress death [1/s] at growth stage 5 + DILE_FW_S6 = 0.2, 0.2, 0.2, 0.2, 0.2, ! coeficient for water leaf stress death [1/s] at growth stage 6 + DILE_FW_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 7 + DILE_FW_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] at growth stage 8 + FRA_GR = 0.2, 0.2, 0.2, 0.2, 0.2, ! fraction of growth respiration + LF_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 1 + LF_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 2 + LF_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 3 + LF_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 4 + LF_OVRC_S5 = 0.2, 0.2, 0.48, 0.48, 0.48, ! fraction of leaf turnover [1/s] at growth stage 5 + LF_OVRC_S6 = 0.3, 0.3, 0.48, 0.48, 0.48, ! fraction of leaf turnover [1/s] at growth stage 6 + LF_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 7 + LF_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] at growth stage 8 + ST_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 1 + ST_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 2 + ST_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 3 + ST_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 4 + ST_OVRC_S5 = 0.2, 0.12, 0.12, 0.12, 0.12, ! fraction of stem turnover [1/s] at growth stage 5 + ST_OVRC_S6 = 0.3, 0.06, 0.06, 0.06, 0.06, ! fraction of stem turnover [1/s] at growth stage 6 + ST_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 7 + ST_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] at growth stage 8 + RT_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 1 + RT_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 2 + RT_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 3 + RT_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 4 + RT_OVRC_S5 = 0.12, 0.12, 0.12, 0.12, 0.12, ! fraction of root tunrover [1/s] at growth stage 5 + RT_OVRC_S6 = 0.06, 0.06, 0.06, 0.06, 0.06, ! fraction of root tunrover [1/s] at growth stage 6 + RT_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 7 + RT_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] at growth stage 8 + LFMR25 = 0.8, 1.0, 1.0, 1.0, 1.0, ! leaf maintenance respiration at 25C [umol CO2/m2/s] + STMR25 = 0.05, 0.05, 0.1, 0.1, 0.1, ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + RTMR25 = 0.05, 0.05, 0.0, 0.0, 0.0, ! root maintenance respiration at 25C [umol CO2/kg bio/s] + GRAINMR25 = 0.0, 0.0, 0.1, 0.1, 0.1, ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + LFPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 1 + LFPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 2 + LFPT_S3 = 0.36, 0.4, 0.4, 0.4, 0.4, ! fraction of carbohydrate flux to leaf at growth stage 3 + LFPT_S4 = 0.1, 0.2, 0.2, 0.2, 0.2, ! fraction of carbohydrate flux to leaf at growth stage 4 + LFPT_S5 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 5 + LFPT_S6 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 6 + LFPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 7 + LFPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf at growth stage 8 + STPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 1 + STPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 2 + STPT_S3 = 0.24, 0.2, 0.2, 0.2, 0.2, ! fraction of carbohydrate flux to stem at growth stage 3 + STPT_S4 = 0.6, 0.5, 0.5, 0.5, 0.5, ! fraction of carbohydrate flux to stem at growth stage 4 + STPT_S5 = 0.0, 0.0, 0.15, 0.15, 0.15, ! fraction of carbohydrate flux to stem at growth stage 5 + STPT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate flux to stem at growth stage 6 + STPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 7 + STPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem at growth stage 8 + RTPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 1 + RTPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 2 + RTPT_S3 = 0.4, 0.4, 0.4, 0.4, 0.4, ! fraction of carbohydrate flux to root at growth stage 3 + RTPT_S4 = 0.3, 0.3, 0.3, 0.3, 0.3, ! fraction of carbohydrate flux to root at growth stage 4 + RTPT_S5 = 0.05, 0.05, 0.05, 0.05, 0.05, ! fraction of carbohydrate flux to root at growth stage 5 + RTPT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate flux to root at growth stage 6 + RTPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 7 + RTPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root at growth stage 8 + GRAINPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 1 + GRAINPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 2 + GRAINPT_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 3 + GRAINPT_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 4 + GRAINPT_S5 = 0.95, 0.95, 0.8, 0.8, 0.8, ! fraction of carbohydrate flux to grain at growth stage 5 + GRAINPT_S6 = 1.0, 1.0, 0.9, 0.9, 0.9, ! fraction of carbohydrate flux to grain at growth stage 6 + GRAINPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 7 + GRAINPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain at growth stage 8 + LFCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 1 + LFCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 2 + LFCT_S3 = 0.0, 0.0, 0.4, 0.4, 0.4, ! fraction of carbohydrate translocation from leaf to grain at growth stage 3 + LFCT_S4 = 0.0, 0.0, 0.3, 0.3, 0.3, ! fraction of carbohydrate translocation from leaf to grain at growth stage 4 + LFCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from leaf to grain at growth stage 5 + LFCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from leaf to grain at growth stage 6 + LFCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 7 + LFCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from leaf to grain at growth stage 8 + STCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 1 + STCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 2 + STCT_S3 = 0.0, 0.0, 0.4, 0.4, 0.4, ! fraction of carbohydrate translocation from stem to grain at growth stage 3 + STCT_S4 = 0.0, 0.0, 0.3, 0.3, 0.3, ! fraction of carbohydrate translocation from stem to grain at growth stage 4 + STCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from stem to grain at growth stage 5 + STCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from stem to grain at growth stage 6 + STCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 7 + STCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from stem to grain at growth stage 8 + RTCT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 1 + RTCT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 2 + RTCT_S3 = 0.0, 0.0, 0.4, 0.4, 0.4, ! fraction of carbohydrate translocation from root to grain at growth stage 3 + RTCT_S4 = 0.0, 0.0, 0.3, 0.3, 0.3, ! fraction of carbohydrate translocation from root to grain at growth stage 4 + RTCT_S5 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from root to grain at growth stage 5 + RTCT_S6 = 0.0, 0.0, 0.05, 0.05, 0.05, ! fraction of carbohydrate translocation from root to grain at growth stage 6 + RTCT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 7 + RTCT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate translocation from root to grain at growth stage 8 + BIO2LAI = 0.015, 0.030, 0.015, 0.015, 0.015, ! leaf area per living leaf biomass [m2/kg] +/ + +&noahmp_tiledrain_parameters + NSOILTYPE = 19 ! num_soil_types + + !-----------------------------------! + ! For simple drainage model ! + !-----------------------------------! + DRAIN_LAYER_OPT = 4 ! soil layer which is applied by drainage + ! 0 - from one specified layer by TD_DEPTH, + ! 1 - from layers 1 & 2, + ! 2 - from layer layers 1, 2, and 3 + ! 3 - from layer 2 and 3 + ! 4 - from layer layers 3, 4 + ! 5 - from all the four layers + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SoilType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! TDSMC_FAC: tile drainage soil moisture factor + TDSMC_FAC = 0.90, 0.90, 0.90, 0.90, 0.90, 1.25, 0.90, 1.0, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, 0.90, + ! TD_DEPTH: depth of drain tube from the soil surface + TD_DEPTH = 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, 4, + ! TD_DC: drainage coefficient (mm/d) + TD_DC = 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, 20.0, + + !-------------------------------------! + ! For Hooghoudt tile drain model ! + !-------------------------------------! + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SoilType: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !-------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! TD_DCOEF: tile drainage coefficient (mm/d) + TD_DCOEF = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + ! TD_D: depth to impervious layer from drain water level [m] + TD_D = 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, + ! TD_ADEPTH: actual depth of impervious layer from land surface [m] + TD_ADEPTH = 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, 2.00, + ! TD_RADI: effective radius of drain tubes [m] + TD_RADI = 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, + ! TD_SPAC: distance between two drain tubes or tiles [m] + TD_SPAC = 60.0, 55.0, 45.0, 20.0, 25.0, 30.0, 40.0, 16.0, 18.0, 50.0, 15.0, 10.0, 35.0, 10.0, 60.0, 60.0, 10.0, 60.0, 60.0, + ! TD_DDRAIN: Depth of drain [m] + TD_DDRAIN = 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, 1.20, + ! KLAT_FAC: multiplication factor to lateral hydrological conductivity + KLAT_FAC = 1.30, 1.80, 2.10, 2.60, 2.90, 2.50, 2.30, 3.00, 2.70, 2.00, 3.10, 3.30, 2.50, 1.00, 1.00, 1.80, 4.00, 1.00, 1.30, +/ + +&noahmp_optional_parameters + !------------------------------------------------------------------------------ + ! Saxton and Rawls 2006 Pedo-transfer function coefficients + !------------------------------------------------------------------------------ + sr2006_theta_1500t_a = -0.024 ! sand coefficient + sr2006_theta_1500t_b = 0.487 ! clay coefficient + sr2006_theta_1500t_c = 0.006 ! orgm coefficient + sr2006_theta_1500t_d = 0.005 ! sand*orgm coefficient + sr2006_theta_1500t_e = -0.013 ! clay*orgm coefficient + sr2006_theta_1500t_f = 0.068 ! sand*clay coefficient + sr2006_theta_1500t_g = 0.031 ! constant adjustment + sr2006_theta_1500_a = 0.14 ! theta_1500t coefficient + sr2006_theta_1500_b = -0.02 ! constant adjustment + sr2006_theta_33t_a = -0.251 ! sand coefficient + sr2006_theta_33t_b = 0.195 ! clay coefficient + sr2006_theta_33t_c = 0.011 ! orgm coefficient + sr2006_theta_33t_d = 0.006 ! sand*orgm coefficient + sr2006_theta_33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_33t_f = 0.452 ! sand*clay coefficient + sr2006_theta_33t_g = 0.299 ! constant adjustment + sr2006_theta_33_a = 1.283 ! theta_33t*theta_33t coefficient + sr2006_theta_33_b = -0.374 ! theta_33t coefficient + sr2006_theta_33_c = -0.015 ! constant adjustment + sr2006_theta_s33t_a = 0.278 ! sand coefficient + sr2006_theta_s33t_b = 0.034 ! clay coefficient + sr2006_theta_s33t_c = 0.022 ! orgm coefficient + sr2006_theta_s33t_d = -0.018 ! sand*orgm coefficient + sr2006_theta_s33t_e = -0.027 ! clay*orgm coefficient + sr2006_theta_s33t_f = -0.584 ! sand*clay coefficient + sr2006_theta_s33t_g = 0.078 ! constant adjustment + sr2006_theta_s33_a = 0.636 ! theta_s33t coefficient + sr2006_theta_s33_b = -0.107 ! constant adjustment + sr2006_psi_et_a = -21.67 ! sand coefficient + sr2006_psi_et_b = -27.93 ! clay coefficient + sr2006_psi_et_c = -81.97 ! theta_s33 coefficient + sr2006_psi_et_d = 71.12 ! sand*theta_s33 coefficient + sr2006_psi_et_e = 8.29 ! clay*theta_s33 coefficient + sr2006_psi_et_f = 14.05 ! sand*clay coefficient + sr2006_psi_et_g = 27.16 ! constant adjustment + sr2006_psi_e_a = 0.02 ! psi_et*psi_et coefficient + sr2006_psi_e_b = -0.113 ! psi_et coefficient + sr2006_psi_e_c = -0.7 ! constant adjustment + sr2006_smcmax_a = -0.097 ! sand adjustment + sr2006_smcmax_b = 0.043 ! constant adjustment +/ + +&noahmp_general_parameters + !------------------------------------------------- + ! this part is originally from GENPARM.TBL + !------------------------------------------------- + SLOPE_DATA = 0.1, 0.6, 1.0, 0.35, 0.55, 0.8, 0.63, 0.0, 0.0 ! slope factor for soil drainage (9 different slope types) + CSOIL_DATA = 2.00E+6 ! Soil heat capacity [J m-3 K-1] + REFDK_DATA = 2.0E-6 ! Parameter in the surface runoff parameterization + REFKDT_DATA = 3.0 ! Parameter in the surface runoff parameterization + FRZK_DATA = 0.15 ! Frozen ground parameter + ZBOT_DATA = -8.0 ! Depth [m] of lower boundary soil temperature + CZIL_DATA = 0.1 ! Parameter used in the calculation of the roughness length for heat +/ + +&noahmp_stas_soil_categories + SLTYPE = "STAS" ! soil dataset: "STAS" or "STAS_RUC" + SLCATS = 19 ! num_soil_types +/ + +&noahmp_soil_stas_parameters + ! 19 total soil types considered by NoahMP + ! 1: SAND + ! 2: LOAMY SAND + ! 3: SANDY LOAM + ! 4: SILT LOAM + ! 5: SILT + ! 6: LOAM + ! 7: SANDY CLAY LOAM + ! 8: SILTY CLAY LOAM + ! 9: CLAY LOAM + ! 10: SANDY CLAY + ! 11: SILTY CLAY + ! 12: CLAY + ! 13: ORGANIC MATERIAL + ! 14: WATER + ! 15: BEDROCK + ! 16: OTHER(land-ice) + ! 17: PLAYA + ! 18: LAVA + ! 19: WHITE SAND + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SOIL TYPE: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! BB: soil B parameter + BB = 2.790, 4.260, 4.740, 5.330, 3.860, 5.250, 6.770, 8.720, 8.170, 10.730, 10.390, 11.550, 5.250, 0.000, 2.790, 4.260, 11.550, 2.790, 2.790 + ! DRYSMC: dry soil moisture threshold + DRYSMC = 0.010, 0.028, 0.047, 0.084, 0.061, 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, 0.010 + ! MAXSMC: saturated value of soil moisture (volumetric) + MAXSMC = 0.339, 0.421, 0.434, 0.476, 0.484, 0.439, 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, 0.339 + ! REFSMC: reference soil moisture (field capacity) (volumetric) + REFSMC = 0.192, 0.283, 0.312, 0.360, 0.347, 0.329, 0.315, 0.387, 0.382, 0.338, 0.404, 0.412, 0.329, 0.000, 0.170, 0.283, 0.454, 0.170, 0.192 + ! SATPSI: saturated soil matric potential + SATPSI = 0.069, 0.036, 0.141, 0.759, 0.955, 0.355, 0.135, 0.617, 0.263, 0.098, 0.324, 0.468, 0.355, 0.000, 0.069, 0.036, 0.468, 0.069, 0.069 + ! SATDK: saturated soil hydraulic conductivity + SATDK = 4.66E-05, 1.41E-05, 5.23E-06, 2.81E-06, 2.18E-06, 3.38E-06, 4.45E-06, 2.03E-06, 2.45E-06, 7.22E-06, 1.34E-06, 9.74E-07, 3.38E-06, 0.00E+00, 1.41E-04, 1.41E-05, 9.74E-07, 1.41E-04, 4.66E-05 + ! SATDW: saturated soil hydraulic diffusivity + SATDW = 2.65E-05, 5.14E-06, 8.05E-06, 2.39E-05, 1.66E-05, 1.43E-05, 1.01E-05, 2.35E-05, 1.13E-05, 1.87E-05, 9.64E-06, 1.12E-05, 1.43E-05, 0.00E+00, 1.36E-04, 5.14E-06, 1.12E-05, 1.36E-04, 2.65E-05 + ! WLTSMC: wilting point soil moisture (volumetric) + WLTSMC = 0.010, 0.028, 0.047, 0.084, 0.061, 0.066, 0.069, 0.120, 0.103, 0.100, 0.126, 0.138, 0.066, 0.000, 0.006, 0.028, 0.030, 0.006, 0.010 + ! QTZ: soil quartz content + QTZ = 0.920, 0.820, 0.600, 0.250, 0.100, 0.400, 0.600, 0.100, 0.350, 0.520, 0.100, 0.250, 0.050, 0.600, 0.070, 0.250, 0.600, 0.520, 0.920 + ! BVIC: VIC model infiltration parameter for VIC runoff + BVIC = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! AXAJ: Tension water distribution inflection parameter for Xinanjiang runoff + AXAJ = 0.009, 0.010, 0.009, 0.010, 0.012, 0.013, 0.014, 0.015, 0.016, 0.015, 0.016, 0.017, 0.012, 0.001, 0.017, 0.017, 0.017, 0.015, 0.009 + ! BXAJ: Tension water distribution shape parameter for Xinanjiang runoff + BXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! XXAJ: Free water distribution shape parameter for Xinanjiang runoff + XXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BDVIC: VIC model infiltration parameter for dynamic VIC runoff + BDVIC = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BBVIC: heterogeniety parameter for infiltration for dynamic VIC runoff + BBVIC = 1.000, 1.010, 1.020, 1.025, 1.000, 1.000, 1.032, 1.035, 1.040, 1.042, 1.045, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000 + ! GDVIC: mean capilary drive (m) for dynamic VIC runoff + GDVIC = 0.050, 0.070, 0.130, 0.200, 0.170, 0.110, 0.260, 0.350, 0.260, 0.300, 0.380, 0.410, 0.500, 0.001, 0.010, 0.001, 0.001, 0.050, 0.020 +/ + +&noahmp_soil_stas_ruc_parameters + ! 19 total soil types considered by NoahMP + ! 1: SAND + ! 2: LOAMY SAND + ! 3: SANDY LOAM + ! 4: SILT LOAM + ! 5: SILT + ! 6: LOAM + ! 7: SANDY CLAY LOAM + ! 8: SILTY CLAY LOAM + ! 9: CLAY LOAM + ! 10: SANDY CLAY + ! 11: SILTY CLAY + ! 12: CLAY + ! 13: ORGANIC MATERIAL + ! 14: WATER + ! 15: BEDROCK + ! 16: OTHER(land-ice) + ! 17: PLAYA + ! 18: LAVA + ! 19: WHITE SAND + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! SOIL TYPE: 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 ! + !----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! + ! BB: soil B parameter + BB = 4.050, 4.380, 4.900, 5.300, 5.300, 5.390, 7.120, 7.750, 5.390, 10.400, 10.400, 11.400, 5.390, 0.000, 4.050, 4.900, 11.400, 4.050, 4.050 + ! DRYSMC: dry soil moisture threshold + DRYSMC = 0.002, 0.035, 0.041, 0.034, 0.034, 0.050, 0.068, 0.060, 0.050, 0.070, 0.070, 0.068, 0.027, 0.000, 0.004, 0.065, 0.030, 0.006, 0.010 + ! HC: not used in current Noah-MP + HC = 1.470, 1.410, 1.340, 1.270, 1.270, 1.210, 1.180, 1.320, 1.210, 1.180, 1.150, 1.090, 1.210, 4.180, 2.030, 2.100, 1.410, 1.410, 1.470 + ! MAXSMC: saturated value of soil moisture (volumetric) + MAXSMC = 0.395, 0.410, 0.435, 0.485, 0.485, 0.451, 0.420, 0.477, 0.451, 0.426, 0.492, 0.482, 0.451, 1.000, 0.200, 0.435, 0.468, 0.200, 0.339 + ! REFSMC: reference soil moisture (field capacity) (volumetric) + REFSMC = 0.174, 0.179, 0.249, 0.369, 0.369, 0.314, 0.299, 0.357, 0.314, 0.316, 0.409, 0.400, 0.314, 1.000, 0.100, 0.249, 0.454, 0.170, 0.236 + ! SATPSI: saturated soil matric potential + SATPSI = 0.121, 0.090, 0.218, 0.786, 0.786, 0.478, 0.299, 0.356, 0.478, 0.153, 0.490, 0.405, 0.478, 0.000, 0.121, 0.218, 0.468, 0.069, 0.069 + ! SATDK: saturated soil hydraulic conductivity + SATDK = 1.76E-04, 1.56E-04, 3.47E-05, 7.20E-06, 7.20E-06, 6.95E-06, 6.30E-06, 1.70E-06, 6.95E-06, 2.17E-06, 1.03E-06, 1.28E-06, 6.95E-06, 0.00E+00, 1.41E-04, 3.47E-05, 9.74E-07, 1.41E-04, 1.76E-04 + ! SATDW: saturated soil hydraulic diffusivity + SATDW = 6.08E-07, 5.14E-06, 8.05E-06, 2.39E-05, 2.39E-05, 1.43E-05, 9.90E-06, 2.37E-05, 1.43E-05, 1.87E-05, 9.64E-06, 1.12E-05, 1.43E-05, 0.00E+00, 1.36E-04, 5.14E-06, 1.12E-05, 1.36E-04, 6.08E-07 + ! WLTSMC: wilting point soil moisture (volumetric) + WLTSMC = 0.033, 0.055, 0.095, 0.143, 0.143, 0.137, 0.148, 0.170, 0.137, 0.158, 0.190, 0.198, 0.117, 0.000, 0.006, 0.114, 0.030, 0.006, 0.060 + ! QTZ: soil quartz content + QTZ = 0.920, 0.820, 0.600, 0.250, 0.100, 0.400, 0.600, 0.100, 0.400, 0.520, 0.100, 0.250, 0.050, 0.000, 0.600, 0.050, 0.600, 0.520, 0.920 + ! BVIC: VIC model infiltration parameter for VIC runoff + BVIC = 0.050, 0.080, 0.090, 0.100, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! AXAJ: Tension water distribution inflection parameter for Xinanjiang runoff + AXAJ = 0.009, 0.010, 0.009, 0.010, 0.012, 0.013, 0.014, 0.015, 0.016, 0.015, 0.016, 0.017, 0.012, 0.001, 0.017, 0.017, 0.017, 0.015, 0.009 + ! BXAJ: Tension water distribution shape parameter for Xinanjiang runoff + BXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! XXAJ: Free water distribution shape parameter for Xinanjiang runoff + XXAJ = 0.050, 0.080, 0.090, 0.250, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BDVIC: VIC model infiltration parameter for dynamic VIC runoff + BDVIC = 0.050, 0.080, 0.090, 0.100, 0.150, 0.180, 0.200, 0.220, 0.230, 0.250, 0.280, 0.300, 0.260, 0.000, 1.000, 1.000, 1.000, 0.350, 0.150 + ! BBVIC: heterogeniety parameter for infiltration for dynamic VIC runoff + BBVIC = 1.000, 1.010, 1.020, 1.025, 1.000, 1.000, 1.032, 1.035, 1.040, 1.042, 1.045, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000, 1.000 + ! GDVIC: mean capilary drive (m) for dynamic VIC runoff + GDVIC = 0.050, 0.070, 0.130, 0.200, 0.170, 0.110, 0.260, 0.350, 0.260, 0.300, 0.380, 0.410, 0.500, 0.001, 0.010, 0.001, 0.001, 0.050, 0.020 +/ diff --git a/src/core_atmosphere/physics/physics_noahmp/src/AtmosForcingMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/AtmosForcingMod.F90 new file mode 100644 index 0000000000..96a7105b12 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/AtmosForcingMod.F90 @@ -0,0 +1,182 @@ +module AtmosForcingMod + +!!! Process input atmospheric forcing variables + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ProcessAtmosForcing(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ATM +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local varibles + integer :: LoopInd ! loop index + integer, parameter :: LoopNum = 10 ! iterations for Twet calculation + real(kind=kind_noahmp) :: PrecipFrozenTot ! total frozen precipitation [mm/s] ! MB/AN : v3.7 + real(kind=kind_noahmp) :: RadDirFrac ! direct solar radiation fraction + real(kind=kind_noahmp) :: RadVisFrac ! visible band solar radiation fraction + real(kind=kind_noahmp) :: VapPresSat ! saturated vapor pressure of air + real(kind=kind_noahmp) :: LatHeatVap ! latent heat of vapor/sublimation + real(kind=kind_noahmp) :: PsychConst ! (cp*p)/(eps*L), psychrometric coefficient + real(kind=kind_noahmp) :: TemperatureDegC ! air temperature [C] + real(kind=kind_noahmp) :: TemperatureWetBulb ! wetbulb temperature + +! ------------------------------------------------------------------------ + associate( & + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle [0-1] + OptRainSnowPartition => noahmp%config%nmlist%OptRainSnowPartition ,& ! in, rain-snow partition physics option + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] forcing at reference height + PrecipConvRefHeight => noahmp%forcing%PrecipConvRefHeight ,& ! in, convective precipitation rate [mm/s] at reference height + PrecipNonConvRefHeight => noahmp%forcing%PrecipNonConvRefHeight ,& ! in, non-convective precipitation rate [mm/s] at reference height + PrecipShConvRefHeight => noahmp%forcing%PrecipShConvRefHeight ,& ! in, shallow convective precipitation rate [mm/s] at reference height + PrecipSnowRefHeight => noahmp%forcing%PrecipSnowRefHeight ,& ! in, snowfall rate [mm/s] at reference height + PrecipGraupelRefHeight => noahmp%forcing%PrecipGraupelRefHeight ,& ! in, graupel rate [mm/s] at reference height + PrecipHailRefHeight => noahmp%forcing%PrecipHailRefHeight ,& ! in, hail rate [mm/s] at reference height + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + SnowfallDensityMax => noahmp%water%param%SnowfallDensityMax ,& ! in, maximum fresh snowfall density [kg/m3] + TemperaturePotRefHeight => noahmp%energy%state%TemperaturePotRefHeight ,& ! out, surface potential temperature [K] + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! out, vapor pressure air [Pa] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! out, density air [kg/m3] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! out, wind speed [m/s] at reference height + RadSwDownDir => noahmp%energy%flux%RadSwDownDir ,& ! out, incoming direct solar radiation [W/m2] + RadSwDownDif => noahmp%energy%flux%RadSwDownDif ,& ! out, incoming diffuse solar radiation [W/m2] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! out, rainfall [mm/s] at reference height + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! out, liquid equivalent snowfall [mm/s] at reference height + PrecipTotRefHeight => noahmp%water%flux%PrecipTotRefHeight ,& ! out, total precipitation [mm/s] at reference height + PrecipConvTotRefHeight => noahmp%water%flux%PrecipConvTotRefHeight ,& ! out, total convective precipitation [mm/s] at reference height + PrecipLargeSclRefHeight => noahmp%water%flux%PrecipLargeSclRefHeight ,& ! out, large-scale precipitation [mm/s] at reference height + PrecipAreaFrac => noahmp%water%state%PrecipAreaFrac ,& ! out, fraction of area receiving precipitation + FrozenPrecipFrac => noahmp%water%state%FrozenPrecipFrac ,& ! out, frozen precipitation fraction + SnowfallDensity => noahmp%water%state%SnowfallDensity & ! out, bulk density of snowfall [kg/m3] + ) +! ------------------------------------------------------------------------ + + ! surface air variables + TemperaturePotRefHeight = TemperatureAirRefHeight * & + (PressureAirRefHeight / PressureAirRefHeight) ** (ConstGasDryAir / ConstHeatCapacAir) + PressureVaporRefHeight = SpecHumidityRefHeight * PressureAirRefHeight / (0.622 + 0.378*SpecHumidityRefHeight) + DensityAirRefHeight = (PressureAirRefHeight - 0.378*PressureVaporRefHeight) / & + (ConstGasDryAir * TemperatureAirRefHeight) + + ! downward solar radiation + RadDirFrac = 0.7 + RadVisFrac = 0.5 + if ( CosSolarZenithAngle <= 0.0 ) RadSwDownRefHeight = 0.0 ! filter by solar zenith angle + RadSwDownDir(1) = RadSwDownRefHeight * RadDirFrac * RadVisFrac ! direct vis + RadSwDownDir(2) = RadSwDownRefHeight * RadDirFrac * (1.0-RadVisFrac) ! direct nir + RadSwDownDif(1) = RadSwDownRefHeight * (1.0-RadDirFrac) * RadVisFrac ! diffuse vis + RadSwDownDif(2) = RadSwDownRefHeight * (1.0-RadDirFrac) * (1.0-RadVisFrac) ! diffuse nir + + ! precipitation + PrecipTotRefHeight = PrecipConvRefHeight + PrecipNonConvRefHeight + PrecipShConvRefHeight + if ( OptRainSnowPartition == 4 ) then + PrecipConvTotRefHeight = PrecipConvRefHeight + PrecipShConvRefHeight + PrecipLargeSclRefHeight = PrecipNonConvRefHeight + else + PrecipConvTotRefHeight = 0.10 * PrecipTotRefHeight + PrecipLargeSclRefHeight = 0.90 * PrecipTotRefHeight + endif + + ! fractional area that receives precipitation (see, Niu et al. 2005) + PrecipAreaFrac = 0.0 + if ( (PrecipConvTotRefHeight+PrecipLargeSclRefHeight) > 0.0 ) then + PrecipAreaFrac = (PrecipConvTotRefHeight + PrecipLargeSclRefHeight) / & + (10.0*PrecipConvTotRefHeight + PrecipLargeSclRefHeight) + endif + + ! partition precipitation into rain and snow. Moved from CANWAT MB/AN: v3.7 + ! Jordan (1991) + if ( OptRainSnowPartition == 1 ) then + if ( TemperatureAirRefHeight > (ConstFreezePoint+2.5) ) then + FrozenPrecipFrac = 0.0 + else + if ( TemperatureAirRefHeight <= (ConstFreezePoint+0.5) ) then + FrozenPrecipFrac = 1.0 + elseif ( TemperatureAirRefHeight <= (ConstFreezePoint+2.0) ) then + FrozenPrecipFrac = 1.0 - (-54.632 + 0.2*TemperatureAirRefHeight) + else + FrozenPrecipFrac = 0.6 + endif + endif + endif + + ! BATS scheme + if ( OptRainSnowPartition == 2 ) then + if ( TemperatureAirRefHeight >= (ConstFreezePoint+2.2) ) then + FrozenPrecipFrac = 0.0 + else + FrozenPrecipFrac = 1.0 + endif + endif + + ! Simple temperature scheme + if ( OptRainSnowPartition == 3 ) then + if ( TemperatureAirRefHeight >= ConstFreezePoint ) then + FrozenPrecipFrac = 0.0 + else + FrozenPrecipFrac = 1.0 + endif + endif + + ! Use WRF microphysics output + ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 + SnowfallDensity = min( SnowfallDensityMax, 67.92+51.25*exp((TemperatureAirRefHeight-ConstFreezePoint)/2.59) ) ! fresh snow density !MB/AN: change to MIN + if ( OptRainSnowPartition == 4 ) then + PrecipFrozenTot = PrecipSnowRefHeight + PrecipGraupelRefHeight + PrecipHailRefHeight + if ( (PrecipNonConvRefHeight > 0.0) .and. (PrecipFrozenTot > 0.0) ) then + FrozenPrecipFrac = min( 1.0, PrecipFrozenTot/PrecipNonConvRefHeight ) + FrozenPrecipFrac = max( 0.0, FrozenPrecipFrac ) + SnowfallDensity = SnowfallDensity * (PrecipSnowRefHeight/PrecipFrozenTot) + & + ConstDensityGraupel * (PrecipGraupelRefHeight/PrecipFrozenTot) + & + ConstDensityHail * (PrecipHailRefHeight/PrecipFrozenTot) + else + FrozenPrecipFrac = 0.0 + endif + endif + + ! wet-bulb scheme (Wang et al., 2019 GRL), C.He, 12/18/2020 + if ( OptRainSnowPartition == 5 ) then + TemperatureDegC = min( 50.0, max(-50.0,(TemperatureAirRefHeight-ConstFreezePoint)) ) ! Kelvin to degree Celsius with limit -50 to +50 + if ( TemperatureAirRefHeight > ConstFreezePoint ) then + LatHeatVap = ConstLatHeatEvap + else + LatHeatVap = ConstLatHeatSublim + endif + PsychConst = ConstHeatCapacAir * PressureAirRefHeight / (0.622 * LatHeatVap) + TemperatureWetBulb = TemperatureDegC - 5.0 ! first guess wetbulb temperature + do LoopInd = 1, LoopNum + VapPresSat = 610.8 * exp( (17.27*TemperatureWetBulb) / (237.3+TemperatureWetBulb) ) + TemperatureWetBulb = TemperatureWetBulb - (VapPresSat - PressureVaporRefHeight) / PsychConst ! Wang et al., 2019 GRL Eq.2 + enddo + FrozenPrecipFrac = 1.0 / (1.0 + 6.99e-5 * exp(2.0*(TemperatureWetBulb+3.97))) ! Wang et al., 2019 GRL Eq. 1 + endif + + ! rain-snow partitioning + RainfallRefHeight = PrecipTotRefHeight * (1.0 - FrozenPrecipFrac) + SnowfallRefHeight = PrecipTotRefHeight * FrozenPrecipFrac + + ! wind speed at reference height for turbulence calculation + WindSpdRefHeight = max(sqrt(WindEastwardRefHeight**2.0 + WindNorthwardRefHeight**2.0), 1.0) + + end associate + + end subroutine ProcessAtmosForcing + +end module AtmosForcingMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckGlacierMod.F90 new file mode 100644 index 0000000000..7b5e839130 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckGlacierMod.F90 @@ -0,0 +1,163 @@ +module BalanceErrorCheckGlacierMod + +!!! Check glacier water and energy balance and report error + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + +!!!! Water balance check initialization + subroutine BalanceWaterInitGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_GLACIER) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg & ! out, total water storage [mm] at the beginning + ) +! ---------------------------------------------------------------------- + + ! compute total glacier water storage before NoahMP processes + ! need more work on including glacier ice mass underneath snow + WaterStorageTotBeg = SnowWaterEquiv + + end associate + + end subroutine BalanceWaterInitGlacier + + +!!!! Water balance check and report error + subroutine BalanceWaterCheckGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg ,& ! in, total water storage [mm] at the beginning + PrecipTotRefHeight => noahmp%water%flux%PrecipTotRefHeight ,& ! in, total precipitation [mm/s] at reference height + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! in, net ground evaporation [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! in, surface runoff [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! in, subsurface runoff [mm/s] + WaterStorageTotEnd => noahmp%water%state%WaterStorageTotEnd ,& ! out, total water storage [mm] at the end + WaterBalanceError => noahmp%water%state%WaterBalanceError & ! out, water balance error [mm] per time step + ) +! ---------------------------------------------------------------------- + + ! Error in water balance should be < 0.1 mm + ! compute total glacier water storage before NoahMP processes + ! need more work on including glacier ice mass underneath snow + WaterStorageTotEnd = SnowWaterEquiv + WaterBalanceError = WaterStorageTotEnd - WaterStorageTotBeg - & + (PrecipTotRefHeight - EvapGroundNet - RunoffSurface - RunoffSubsurface) * MainTimeStep + +#ifndef WRF_HYDRO + if ( abs(WaterBalanceError) > 0.1 ) then + if ( WaterBalanceError > 0) then + write(*,*) "The model is gaining water (WaterBalanceError is positive)" + else + write(*,*) "The model is losing water (WaterBalanceError is negative)" + endif + write(*,*) "WaterBalanceError = ",WaterBalanceError, "kg m{-2} timestep{-1}" + write(*, & + '(" GridIndexI GridIndexJ WaterStorageTotEnd WaterStorageTotBeg PrecipTotRefHeight & + EvapGroundNet RunoffSurface RunoffSubsurface")') + write(*,'(i6,1x,i6,1x,2f15.3,9f11.5)') GridIndexI, GridIndexJ, WaterStorageTotEnd, WaterStorageTotBeg, & + PrecipTotRefHeight*MainTimeStep, EvapGroundNet*MainTimeStep, & + RunoffSurface*MainTimeStep, RunoffSubsurface*MainTimeStep + stop "Error: Water budget problem in NoahMP LSM" + endif +#endif + + end associate + + end subroutine BalanceWaterCheckGlacier + + +!!!! Energy balance check and error report + subroutine BalanceEnergyCheckGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! in, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! in, total reflected solar radiation [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! in, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! in, total sensible heat [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! in, total ground latent heat [W/m2] (+ to atm) + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! in, total ground heat flux [W/m2] (+ to soil/snow) + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! in, precipitation advected heat - total [W/m2] + EnergyBalanceError => noahmp%energy%state%EnergyBalanceError ,& ! out, error in surface energy balance [W/m2] + RadSwBalanceError => noahmp%energy%state%RadSwBalanceError & ! out, error in shortwave radiation balance [W/m2] + ) +! ---------------------------------------------------------------------- + + ! error in shortwave radiation balance should be <0.01 W/m2 + RadSwBalanceError = RadSwDownRefHeight - (RadSwAbsSfc + RadSwReflSfc) + ! print out diagnostics when error is large + if ( abs(RadSwBalanceError) > 0.01 ) then + write(*,*) "GridIndexI, GridIndexJ = ", GridIndexI, GridIndexJ + write(*,*) "RadSwBalanceError = ", RadSwBalanceError + write(*,*) "RadSwDownRefHeight = ", RadSwDownRefHeight + write(*,*) "RadSwReflSfc = ", RadSwReflSfc + write(*,*) "RadSwAbsGrd = ", RadSwAbsGrd + write(*,*) "RadSwAbsSfc = ", RadSwAbsSfc + stop "Error: Solar radiation budget problem in NoahMP LSM" + endif + + ! error in surface energy balance should be <0.01 W/m2 + EnergyBalanceError = RadSwAbsGrd + HeatPrecipAdvSfc - (RadLwNetSfc + HeatSensibleSfc + HeatLatentGrd + HeatGroundTot) + ! print out diagnostics when error is large + if ( abs(EnergyBalanceError) > 0.01 ) then + write(*,*) 'EnergyBalanceError = ', EnergyBalanceError, ' at GridIndexI,GridIndexJ: ', GridIndexI, GridIndexJ + write(*,'(a17,F10.4)' ) "Net longwave: ", RadLwNetSfc + write(*,'(a17,F10.4)' ) "Total sensible: ", HeatSensibleSfc + write(*,'(a17,F10.4)' ) "Ground evap: ", HeatLatentGrd + write(*,'(a17,F10.4)' ) "Total ground: ", HeatGroundTot + write(*,'(a17,4F10.4)') "Precip advected: ", HeatPrecipAdvSfc + write(*,'(a17,F10.4)' ) "absorbed shortwave: ", RadSwAbsGrd + stop "Error: Surface energy budget problem in NoahMP LSM" + endif + + end associate + + end subroutine BalanceEnergyCheckGlacier + +end module BalanceErrorCheckGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckMod.F90 new file mode 100644 index 0000000000..f076e2a5e5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BalanceErrorCheckMod.F90 @@ -0,0 +1,255 @@ +module BalanceErrorCheckMod + +!!! Check water and energy balance and report error + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + +!!!! Water balance check initialization + subroutine BalanceWaterInit(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_SFLX) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! in, canopy intercepted liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! in, canopy intercepted ice [mm] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! in, water storage in aquifer [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg & ! out, total water storage [mm] at the beginning + ) +! ---------------------------------------------------------------------- + + ! compute total water storage before NoahMP processes + if ( SurfaceType == 1 ) then ! soil + WaterStorageTotBeg = CanopyLiqWater + CanopyIce + SnowWaterEquiv + WaterStorageAquifer + do LoopInd = 1, NumSoilLayer + WaterStorageTotBeg = WaterStorageTotBeg + SoilMoisture(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + enddo + endif + + end associate + + end subroutine BalanceWaterInit + + +!!!! Water balance check and report error + subroutine BalanceWaterCheck(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + FlagCropland => noahmp%config%domain%FlagCropland ,& ! in, flag to identify croplands + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to calculate soil process + IrriFracThreshold => noahmp%water%param%IrriFracThreshold ,& ! in, irrigation fraction parameter + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, total input irrigation fraction + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! in, canopy intercepted liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! in, canopy intercepted ice [mm] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! in, water storage in aquifer [mm] + WaterStorageTotBeg => noahmp%water%state%WaterStorageTotBeg ,& ! in, total water storage [mm] at the beginning + PrecipTotRefHeight => noahmp%water%flux%PrecipTotRefHeight ,& ! in, total precipitation [mm/s] at reference height + EvapCanopyNet => noahmp%water%flux%EvapCanopyNet ,& ! in, evaporation of intercepted water [mm/s] + Transpiration => noahmp%water%flux%Transpiration ,& ! in, transpiration rate [mm/s] + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! in, net ground (soil/snow) evaporation [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! in, surface runoff [mm/dt_soil] per soil timestep + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! in, subsurface runoff [mm/dt_soil] per soil timestep + TileDrain => noahmp%water%flux%TileDrain ,& ! in, tile drainage [mm/dt_soil] per soil timestep + IrrigationRateSprinkler => noahmp%water%flux%IrrigationRateSprinkler ,& ! in, rate of irrigation by sprinkler [m/timestep] + IrrigationRateMicro => noahmp%water%flux%IrrigationRateMicro ,& ! in, micro irrigation water rate [m/timestep] + IrrigationRateFlood => noahmp%water%flux%IrrigationRateFlood ,& ! in, flood irrigation water rate [m/timestep] + SfcWaterTotChgAcc => noahmp%water%flux%SfcWaterTotChgAcc ,& ! inout, accumulated snow,soil,canopy water change per soil timestep [mm] + PrecipTotAcc => noahmp%water%flux%PrecipTotAcc ,& ! inout, accumulated precipitation per soil timestep [mm] + EvapCanopyNetAcc => noahmp%water%flux%EvapCanopyNetAcc ,& ! inout, accumulated net canopy evaporation per soil timestep [mm] + TranspirationAcc => noahmp%water%flux%TranspirationAcc ,& ! inout, accumulated transpiration per soil timestep [mm] + EvapGroundNetAcc => noahmp%water%flux%EvapGroundNetAcc ,& ! inout, accumulated net ground evaporation per soil timestep [mm] + WaterStorageTotEnd => noahmp%water%state%WaterStorageTotEnd ,& ! out, total water storage [mm] at the end + WaterBalanceError => noahmp%water%state%WaterBalanceError & ! out, water balance error [mm] per time step + ) +! ---------------------------------------------------------------------- + + ! before water balance check, add irrigation water to precipitation + if ( (FlagCropland .eqv. .true.) .and. (IrrigationFracGrid >= IrriFracThreshold) ) then + PrecipTotRefHeight = PrecipTotRefHeight + IrrigationRateSprinkler * 1000.0 / MainTimeStep ! irrigation + endif + + ! only water balance check for every soil timestep + ! Error in water balance should be < 0.1 mm + if ( SurfaceType == 1 ) then ! soil + WaterStorageTotEnd = CanopyLiqWater + CanopyIce + SnowWaterEquiv + WaterStorageAquifer + do LoopInd = 1, NumSoilLayer + WaterStorageTotEnd = WaterStorageTotEnd + SoilMoisture(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + enddo + ! accumualted water change (only for canopy and snow during non-soil timestep) + SfcWaterTotChgAcc = SfcWaterTotChgAcc + (WaterStorageTotEnd - WaterStorageTotBeg) ! snow, canopy, and soil water change + PrecipTotAcc = PrecipTotAcc + PrecipTotRefHeight * MainTimeStep ! accumulated precip + EvapCanopyNetAcc = EvapCanopyNetAcc + EvapCanopyNet * MainTimeStep ! accumulated canopy evapo + TranspirationAcc = TranspirationAcc + Transpiration * MainTimeStep ! accumulated transpiration + EvapGroundNetAcc = EvapGroundNetAcc + EvapGroundNet * MainTimeStep ! accumulated soil evapo + + ! check water balance at soil timestep + if ( FlagSoilProcess .eqv. .true. ) then + WaterBalanceError = SfcWaterTotChgAcc - (PrecipTotAcc + IrrigationRateMicro*1000.0 + IrrigationRateFlood*1000.0 - & + EvapCanopyNetAcc - TranspirationAcc - EvapGroundNetAcc - RunoffSurface - RunoffSubsurface - & + TileDrain) +#ifndef WRF_HYDRO + if ( abs(WaterBalanceError) > 0.1 ) then + if ( WaterBalanceError > 0 ) then + write(*,*) "The model is gaining water (WaterBalanceError is positive)" + else + write(*,*) "The model is losing water (WaterBalanceError is negative)" + endif + write(*,*) 'WaterBalanceError = ',WaterBalanceError, "kg m{-2} timestep{-1}" + write(*, & + '(" GridIndexI GridIndexJ SfcWaterTotChgAcc PrecipTotRefHeightAcc IrrigationRateMicro & + IrrigationRateFlood EvapCanopyNetAcc EvapGroundNetAcc TranspirationAcc RunoffSurface & + RunoffSubsurface WaterTableDepth TileDrain")') + write(*,'(i6,i6,f10.3,10f10.5)') GridIndexI, GridIndexJ, SfcWaterTotChgAcc, PrecipTotAcc, & + IrrigationRateMicro*1000.0, IrrigationRateFlood*1000.0, & + EvapCanopyNetAcc, EvapGroundNetAcc, TranspirationAcc, RunoffSurface, & + RunoffSubsurface, WaterTableDepth, TileDrain + stop "Error: Water budget problem in NoahMP LSM" + endif +#endif + endif ! FlagSoilProcess + + else ! water point + WaterBalanceError = 0.0 + endif + + end associate + + end subroutine BalanceWaterCheck + + +!!!! Energy balance check and error report + subroutine BalanceEnergyCheck(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ERROR +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! in, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! in, total reflected solar radiation [W/m2] + RadSwReflVeg => noahmp%energy%flux%RadSwReflVeg ,& ! in, reflected solar radiation by vegetation [W/m2] + RadSwReflGrd => noahmp%energy%flux%RadSwReflGrd ,& ! in, reflected solar radiation by ground [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! in, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! in, total sensible heat [W/m2] (+ to atm) + HeatLatentCanopy => noahmp%energy%flux%HeatLatentCanopy ,& ! in, canopy latent heat flux [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! in, total ground latent heat [W/m2] (+ to atm) + HeatLatentTransp => noahmp%energy%flux%HeatLatentTransp ,& ! in, latent heat flux from transpiration [W/m2] (+ to atm) + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! in, total ground heat flux [W/m2] (+ to soil/snow) + RadSwAbsVeg => noahmp%energy%flux%RadSwAbsVeg ,& ! in, solar radiation absorbed by vegetation [W/m2] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! in, precipitation advected heat - total [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! in, precipitation advected heat - under canopy net [W/m2] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! in, precipitation advected heat - vegetation net [W/m2] + HeatLatentIrriEvap => noahmp%energy%flux%HeatLatentIrriEvap ,& ! in, latent heating due to sprinkler evaporation [W/m2] + HeatCanStorageChg => noahmp%energy%flux%HeatCanStorageChg ,& ! in, canopy heat storage change [W/m2] + EnergyBalanceError => noahmp%energy%state%EnergyBalanceError ,& ! out, error in surface energy balance [W/m2] + RadSwBalanceError => noahmp%energy%state%RadSwBalanceError & ! out, error in shortwave radiation balance [W/m2] + ) +! ---------------------------------------------------------------------- + + ! error in shortwave radiation balance should be <0.01 W/m2 + RadSwBalanceError = RadSwDownRefHeight - (RadSwAbsSfc + RadSwReflSfc) + ! print out diagnostics when error is large + if ( abs(RadSwBalanceError) > 0.01 ) then + write(*,*) "GridIndexI, GridIndexJ = ", GridIndexI, GridIndexJ + write(*,*) "RadSwBalanceError = ", RadSwBalanceError + write(*,*) "VEGETATION ---------" + write(*,*) "RadSwDownRefHeight * VegFrac = ", RadSwDownRefHeight*VegFrac + write(*,*) "VegFrac*RadSwAbsVeg + RadSwAbsGrd = ", VegFrac*RadSwAbsVeg+RadSwAbsGrd + write(*,*) "VegFrac*RadSwReflVeg + RadSwReflGrd = ", VegFrac*RadSwReflVeg+RadSwReflGrd + write(*,*) "GROUND -------" + write(*,*) "(1 - VegFrac) * RadSwDownRefHeight = ", (1.0-VegFrac)*RadSwDownRefHeight + write(*,*) "(1 - VegFrac) * RadSwAbsGrd = ", (1.0-VegFrac)*RadSwAbsGrd + write(*,*) "(1 - VegFrac) * RadSwReflGrd = ", (1.0-VegFrac)*RadSwReflGrd + write(*,*) "RadSwReflVeg = ", RadSwReflVeg + write(*,*) "RadSwReflGrd = ", RadSwReflGrd + write(*,*) "RadSwReflSfc = ", RadSwReflSfc + write(*,*) "RadSwAbsVeg = ", RadSwAbsVeg + write(*,*) "RadSwAbsGrd = ", RadSwAbsGrd + write(*,*) "RadSwAbsSfc = ", RadSwAbsSfc + stop "Error: Solar radiation budget problem in NoahMP LSM" + endif + + ! error in surface energy balance should be <0.01 W/m2 + EnergyBalanceError = RadSwAbsVeg + RadSwAbsGrd + HeatPrecipAdvSfc - & + (RadLwNetSfc + HeatSensibleSfc + HeatLatentCanopy + HeatLatentGrd + & + HeatLatentTransp + HeatGroundTot + HeatLatentIrriEvap + HeatCanStorageChg) + ! print out diagnostics when error is large + if ( abs(EnergyBalanceError) > 0.01 ) then + write(*,*) 'EnergyBalanceError = ', EnergyBalanceError, ' at GridIndexI,GridIndexJ: ', GridIndexI, GridIndexJ + write(*,'(a17,F10.4)' ) "Net solar: ", RadSwAbsSfc + write(*,'(a17,F10.4)' ) "Net longwave: ", RadLwNetSfc + write(*,'(a17,F10.4)' ) "Total sensible: ", HeatSensibleSfc + write(*,'(a17,F10.4)' ) "Canopy evap: ", HeatLatentCanopy + write(*,'(a17,F10.4)' ) "Ground evap: ", HeatLatentGrd + write(*,'(a17,F10.4)' ) "Transpiration: ", HeatLatentTransp + write(*,'(a17,F10.4)' ) "Total ground: ", HeatGroundTot + write(*,'(a17,F10.4)' ) "Sprinkler: ", HeatLatentIrriEvap + write(*,'(a17,F10.4)' ) "Canopy heat storage change: ", HeatCanStorageChg + write(*,'(a17,4F10.4)') "Precip advected: ", HeatPrecipAdvSfc,HeatPrecipAdvCanopy,HeatPrecipAdvVegGrd,HeatPrecipAdvBareGrd + write(*,'(a17,F10.4)' ) "Veg fraction: ", VegFrac + stop "Error: Energy budget problem in NoahMP LSM" + endif + + end associate + + end subroutine BalanceEnergyCheck + +end module BalanceErrorCheckMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemCropMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemCropMainMod.F90 new file mode 100644 index 0000000000..c0afe27ea7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemCropMainMod.F90 @@ -0,0 +1,115 @@ +module BiochemCropMainMod + +!!! Main Biogeochemistry module for dynamic crop (as opposed to natural vegetation) +!!! currently only include carbon processes (RE Dickinson et al.(1998) and Liu et al., 2014)) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use CarbonFluxCropMod, only : CarbonFluxCrop + use CropGrowDegreeDayMod, only : CropGrowDegreeDay + use CropPhotosynthesisMod, only : CropPhotosynthesis + + implicit none + +contains + + subroutine BiochemCropMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CARBON_CROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Modified by Xing Liu, 2014 +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! loop index + +!------------------------------------------------------------------------- + associate( & + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, snow/soil layer thickness [m] + IndexWaterPoint => noahmp%config%domain%IndexWaterPoint ,& ! in, water point flag + IndexIcePoint => noahmp%config%domain%IndexIcePoint ,& ! in, land ice flag + IndexBarrenPoint => noahmp%config%domain%IndexBarrenPoint ,& ! in, bare soil flag + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, soil moisture (ice + liq.) [m3/m3] + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [g/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [g/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [g/m2] + WoodMass => noahmp%biochem%state%WoodMass ,& ! inout, mass of wood (incl. woody roots) [g/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [g/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [g/m2] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, net instantaneous assimilation [g/m2/s C] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, net primary productivity [g/m2/s C] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [g/m2/s CO2] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [g/m2/s C] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration [g/m2/s C] + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [g/m2 C] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon ([g/m2 C] + GrainMass => noahmp%biochem%state%GrainMass ,& ! out, mass of grain [g/m2] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! out, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress & ! out, water stress coeficient (1.0 for wilting) + ) +!------------------------------------------------------------------------ + + ! initialize + NetEcoExchange = 0.0 + NetPriProductionTot = 0.0 + GrossPriProduction = 0.0 + + ! no biogeochemistry in non-vegetated points + if ( (VegType == IndexWaterPoint) .or. (VegType == IndexBarrenPoint) .or. & + (VegType == IndexIcePoint ) .or. (FlagUrban .eqv. .true.) ) then + LeafAreaIndex = 0.0 + StemAreaIndex = 0.0 + GrossPriProduction = 0.0 + NetPriProductionTot = 0.0 + NetEcoExchange = 0.0 + RespirationPlantTot = 0.0 + RespirationSoilOrg = 0.0 + CarbonMassSoilTot = 0.0 + CarbonMassLiveTot = 0.0 + LeafMass = 0.0 + RootMass = 0.0 + StemMass = 0.0 + WoodMass = 0.0 + CarbonMassDeepSoil = 0.0 + CarbonMassShallowSoil = 0.0 + GrainMass = 0.0 + return + endif + + ! start biogeochemistry process + ! water stress + SoilWaterStress = 1.0 - SoilTranspFacAcc + SoilWaterRootZone = 0.0 + do LoopInd = 1, NumSoilLayerRoot + SoilWaterRootZone = SoilWaterRootZone + SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) * & + ThicknessSnowSoilLayer(LoopInd) / (-DepthSoilLayer(NumSoilLayerRoot)) + enddo + + ! start crop carbon process + ! Note: The following CropPhotosynthesis is not used currently. + ! Photosynthesis rate is directly from calculations in the energy part (similar to the treatment in CARBON subroutine) + + !call CropPhotosynthesis(noahmp) + call CropGrowDegreeDay(noahmp) + call CarbonFluxCrop(noahmp) + + end associate + + end subroutine BiochemCropMain + +end module BiochemCropMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemNatureVegMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemNatureVegMainMod.F90 new file mode 100644 index 0000000000..93a0a9769e --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemNatureVegMainMod.F90 @@ -0,0 +1,109 @@ +module BiochemNatureVegMainMod + +!!! Main Biogeochemistry module for dynamic generic vegetation (as opposed to explicit crop scheme) +!!! currently only include carbon processes (RE Dickinson et al.(1998) and Guo-Yue Niu(2004)) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use CarbonFluxNatureVegMod, only : CarbonFluxNatureVeg + + implicit none + +contains + + subroutine BiochemNatureVegMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CARBON +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! loop index + +!------------------------------------------------------------------------ + associate( & + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, snow/soil layer thickness [m] + IndexWaterPoint => noahmp%config%domain%IndexWaterPoint ,& ! in, water point flag + IndexIcePoint => noahmp%config%domain%IndexIcePoint ,& ! in, land ice flag + IndexBarrenPoint => noahmp%config%domain%IndexBarrenPoint ,& ! in, bare soil flag + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, soil moisture (ice + liq.) [m3/m3] + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + LeafAreaPerMass1side => noahmp%biochem%param%LeafAreaPerMass1side ,& ! in, single-side leaf area per Kg [m2/kg] + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [g/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [g/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [g/m2] + WoodMass => noahmp%biochem%state%WoodMass ,& ! inout, mass of wood (incl. woody roots) [g/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [g/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [g/m2] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, net instantaneous assimilation [g/m2/s C] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, net primary productivity [g/m2/s C] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [g/m2/s CO2] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [g/m2/s C] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration [g/m2/s C] + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [g/m2 C] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon ([g/m2 C] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! out, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress ,& ! out, water stress coeficient (1. for wilting) + LeafAreaPerMass => noahmp%biochem%state%LeafAreaPerMass & ! out, leaf area per unit mass [m2/g] + ) +!----------------------------------------------------------------------- + + ! initialize + NetEcoExchange = 0.0 + NetPriProductionTot = 0.0 + GrossPriProduction = 0.0 + + ! no biogeochemistry in non-vegetated points + if ( (VegType == IndexWaterPoint) .or. (VegType == IndexBarrenPoint) .or. & + (VegType == IndexIcePoint ) .or. (FlagUrban .eqv. .true.) ) then + LeafAreaIndex = 0.0 + StemAreaIndex = 0.0 + GrossPriProduction = 0.0 + NetPriProductionTot = 0.0 + NetEcoExchange = 0.0 + RespirationPlantTot = 0.0 + RespirationSoilOrg = 0.0 + CarbonMassSoilTot = 0.0 + CarbonMassLiveTot = 0.0 + LeafMass = 0.0 + RootMass = 0.0 + StemMass = 0.0 + WoodMass = 0.0 + CarbonMassDeepSoil = 0.0 + CarbonMassShallowSoil = 0.0 + return + endif + + ! start biogeochemistry process + LeafAreaPerMass = LeafAreaPerMass1side / 1000.0 ! m2/kg -> m2/g + + ! water stress + SoilWaterStress = 1.0 - SoilTranspFacAcc + SoilWaterRootZone = 0.0 + do LoopInd = 1, NumSoilLayerRoot + SoilWaterRootZone = SoilWaterRootZone + SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) * & + ThicknessSnowSoilLayer(LoopInd) / (-DepthSoilLayer(NumSoilLayerRoot)) + enddo + + ! start carbon process + call CarbonFluxNatureVeg(noahmp) + + end associate + + end subroutine BiochemNatureVegMain + +end module BiochemNatureVegMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarInitMod.F90 new file mode 100644 index 0000000000..e53aa108cf --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarInitMod.F90 @@ -0,0 +1,193 @@ +module BiochemVarInitMod + +!!! Initialize column (1-D) Noah-MP biochemistry (carbon,nitrogen,etc) variables +!!! Biochemistry variables should be first defined in BiochemVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + + subroutine BiochemVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + associate( NumCropGrowStage => noahmp%config%domain%NumCropGrowStage ) + + ! biochem state variables + noahmp%biochem%state%PlantGrowStage = undefined_int + noahmp%biochem%state%IndexPlanting = undefined_int + noahmp%biochem%state%IndexHarvest = undefined_int + noahmp%biochem%state%IndexGrowSeason = undefined_real + noahmp%biochem%state%NitrogenConcFoliage = undefined_real + noahmp%biochem%state%LeafMass = undefined_real + noahmp%biochem%state%RootMass = undefined_real + noahmp%biochem%state%StemMass = undefined_real + noahmp%biochem%state%WoodMass = undefined_real + noahmp%biochem%state%CarbonMassDeepSoil = undefined_real + noahmp%biochem%state%CarbonMassShallowSoil = undefined_real + noahmp%biochem%state%CarbonMassSoilTot = undefined_real + noahmp%biochem%state%CarbonMassLiveTot = undefined_real + noahmp%biochem%state%LeafAreaPerMass = undefined_real + noahmp%biochem%state%StemAreaPerMass = undefined_real + noahmp%biochem%state%LeafMassMin = undefined_real + noahmp%biochem%state%StemMassMin = undefined_real + noahmp%biochem%state%CarbonFracToLeaf = undefined_real + noahmp%biochem%state%CarbonFracToRoot = undefined_real + noahmp%biochem%state%CarbonFracToWood = undefined_real + noahmp%biochem%state%CarbonFracToStem = undefined_real + noahmp%biochem%state%WoodCarbonFrac = undefined_real + noahmp%biochem%state%CarbonFracToWoodRoot = undefined_real + noahmp%biochem%state%MicroRespFactorSoilWater = undefined_real + noahmp%biochem%state%MicroRespFactorSoilTemp = undefined_real + noahmp%biochem%state%RespFacNitrogenFoliage = undefined_real + noahmp%biochem%state%RespFacTemperature = undefined_real + noahmp%biochem%state%RespReductionFac = undefined_real + noahmp%biochem%state%GrainMass = undefined_real + noahmp%biochem%state%GrowDegreeDay = undefined_real + + ! biochem flux variables + noahmp%biochem%flux%PhotosynLeafSunlit = undefined_real + noahmp%biochem%flux%PhotosynLeafShade = undefined_real + noahmp%biochem%flux%PhotosynCrop = undefined_real + noahmp%biochem%flux%PhotosynTotal = undefined_real + noahmp%biochem%flux%GrossPriProduction = undefined_real + noahmp%biochem%flux%NetPriProductionTot = undefined_real + noahmp%biochem%flux%NetEcoExchange = undefined_real + noahmp%biochem%flux%RespirationPlantTot = undefined_real + noahmp%biochem%flux%RespirationSoilOrg = undefined_real + noahmp%biochem%flux%CarbonToAtmos = undefined_real + noahmp%biochem%flux%NetPriProductionLeaf = undefined_real + noahmp%biochem%flux%NetPriProductionRoot = undefined_real + noahmp%biochem%flux%NetPriProductionWood = undefined_real + noahmp%biochem%flux%NetPriProductionStem = undefined_real + noahmp%biochem%flux%GrowthRespLeaf = undefined_real + noahmp%biochem%flux%GrowthRespRoot = undefined_real + noahmp%biochem%flux%GrowthRespWood = undefined_real + noahmp%biochem%flux%GrowthRespStem = undefined_real + noahmp%biochem%flux%LeafMassMaxChg = undefined_real + noahmp%biochem%flux%StemMassMaxChg = undefined_real + noahmp%biochem%flux%CarbonDecayToStable = undefined_real + noahmp%biochem%flux%RespirationLeaf = undefined_real + noahmp%biochem%flux%RespirationStem = undefined_real + noahmp%biochem%flux%GrowthRespGrain = undefined_real + noahmp%biochem%flux%NetPriProductionGrain = undefined_real + noahmp%biochem%flux%ConvRootToGrain = undefined_real + noahmp%biochem%flux%ConvStemToGrain = undefined_real + noahmp%biochem%flux%RespirationWood = undefined_real + noahmp%biochem%flux%RespirationLeafMaint = undefined_real + noahmp%biochem%flux%RespirationRoot = undefined_real + noahmp%biochem%flux%DeathLeaf = undefined_real + noahmp%biochem%flux%DeathStem = undefined_real + noahmp%biochem%flux%CarbonAssim = undefined_real + noahmp%biochem%flux%TurnoverLeaf = undefined_real + noahmp%biochem%flux%TurnoverStem = undefined_real + noahmp%biochem%flux%TurnoverWood = undefined_real + noahmp%biochem%flux%RespirationSoil = undefined_real + noahmp%biochem%flux%TurnoverRoot = undefined_real + noahmp%biochem%flux%CarbohydrAssim = undefined_real + noahmp%biochem%flux%TurnoverGrain = undefined_real + noahmp%biochem%flux%ConvLeafToGrain = undefined_real + noahmp%biochem%flux%RespirationGrain = undefined_real + + ! biochem parameter variables + noahmp%biochem%param%DatePlanting = undefined_int + noahmp%biochem%param%DateHarvest = undefined_int + noahmp%biochem%param%QuantumEfficiency25C = undefined_real + noahmp%biochem%param%CarboxylRateMax25C = undefined_real + noahmp%biochem%param%CarboxylRateMaxQ10 = undefined_real + noahmp%biochem%param%PhotosynPathC3 = undefined_real + noahmp%biochem%param%SlopeConductToPhotosyn = undefined_real + noahmp%biochem%param%TemperatureMinPhotosyn = undefined_real + noahmp%biochem%param%LeafAreaPerMass1side = undefined_real + noahmp%biochem%param%NitrogenConcFoliageMax = undefined_real + noahmp%biochem%param%WoodToRootRatio = undefined_real + noahmp%biochem%param%WoodPoolIndex = undefined_real + noahmp%biochem%param%TurnoverCoeffLeafVeg = undefined_real + noahmp%biochem%param%LeafDeathWaterCoeffVeg = undefined_real + noahmp%biochem%param%LeafDeathTempCoeffVeg = undefined_real + noahmp%biochem%param%MicroRespCoeff = undefined_real + noahmp%biochem%param%RespMaintQ10 = undefined_real + noahmp%biochem%param%RespMaintLeaf25C = undefined_real + noahmp%biochem%param%RespMaintStem25C = undefined_real + noahmp%biochem%param%RespMaintRoot25C = undefined_real + noahmp%biochem%param%RespMaintGrain25C = undefined_real + noahmp%biochem%param%GrowthRespFrac = undefined_real + noahmp%biochem%param%TemperaureLeafFreeze = undefined_real + noahmp%biochem%param%LeafAreaPerBiomass = undefined_real + noahmp%biochem%param%TempBaseGrowDegDay = undefined_real + noahmp%biochem%param%TempMaxGrowDegDay = undefined_real + noahmp%biochem%param%GrowDegDayEmerg = undefined_real + noahmp%biochem%param%GrowDegDayInitVeg = undefined_real + noahmp%biochem%param%GrowDegDayPostVeg = undefined_real + noahmp%biochem%param%GrowDegDayInitReprod = undefined_real + noahmp%biochem%param%GrowDegDayMature = undefined_real + noahmp%biochem%param%PhotosynRadFrac = undefined_real + noahmp%biochem%param%TempMinCarbonAssim = undefined_real + noahmp%biochem%param%TempMaxCarbonAssim = undefined_real + noahmp%biochem%param%TempMaxCarbonAssimMax = undefined_real + noahmp%biochem%param%CarbonAssimRefMax = undefined_real + noahmp%biochem%param%LightExtCoeff = undefined_real + noahmp%biochem%param%LightUseEfficiency = undefined_real + noahmp%biochem%param%CarbonAssimReducFac = undefined_real + noahmp%biochem%param%StemAreaIndexMin = undefined_real + noahmp%biochem%param%WoodAllocFac = undefined_real + noahmp%biochem%param%WaterStressCoeff = undefined_real + noahmp%biochem%param%LeafAreaIndexMin = undefined_real + noahmp%biochem%param%TurnoverCoeffRootVeg = undefined_real + noahmp%biochem%param%WoodRespCoeff = undefined_real + + if ( .not. allocated(noahmp%biochem%param%LeafDeathTempCoeffCrop) ) & + allocate( noahmp%biochem%param%LeafDeathTempCoeffCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%LeafDeathWaterCoeffCrop) ) & + allocate( noahmp%biochem%param%LeafDeathWaterCoeffCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrLeafToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrLeafToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrStemToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrStemToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrRootToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrRootToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToLeaf) ) & + allocate( noahmp%biochem%param%CarbohydrFracToLeaf(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToStem) ) & + allocate( noahmp%biochem%param%CarbohydrFracToStem(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToRoot) ) & + allocate( noahmp%biochem%param%CarbohydrFracToRoot(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%CarbohydrFracToGrain) ) & + allocate( noahmp%biochem%param%CarbohydrFracToGrain(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%TurnoverCoeffLeafCrop) ) & + allocate( noahmp%biochem%param%TurnoverCoeffLeafCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%TurnoverCoeffStemCrop) ) & + allocate( noahmp%biochem%param%TurnoverCoeffStemCrop(1:NumCropGrowStage) ) + if ( .not. allocated(noahmp%biochem%param%TurnoverCoeffRootCrop) ) & + allocate( noahmp%biochem%param%TurnoverCoeffRootCrop(1:NumCropGrowStage) ) + + noahmp%biochem%param%LeafDeathTempCoeffCrop (:) = undefined_real + noahmp%biochem%param%LeafDeathWaterCoeffCrop(:) = undefined_real + noahmp%biochem%param%CarbohydrLeafToGrain (:) = undefined_real + noahmp%biochem%param%CarbohydrStemToGrain (:) = undefined_real + noahmp%biochem%param%CarbohydrRootToGrain (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToLeaf (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToStem (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToRoot (:) = undefined_real + noahmp%biochem%param%CarbohydrFracToGrain (:) = undefined_real + noahmp%biochem%param%TurnoverCoeffLeafCrop (:) = undefined_real + noahmp%biochem%param%TurnoverCoeffStemCrop (:) = undefined_real + noahmp%biochem%param%TurnoverCoeffRootCrop (:) = undefined_real + + end associate + + end subroutine BiochemVarInitDefault + +end module BiochemVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarType.F90 new file mode 100644 index 0000000000..9e9cd3e44c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/BiochemVarType.F90 @@ -0,0 +1,177 @@ +module BiochemVarType + +!!! Define column (1-D) Noah-MP Biochemistry (carbon,nitrogen,etc) variables +!!! Biochemistry variable initialization is done in BiochemVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "flux" sub-type of biochem (biochem%flux%variable) + type :: flux_type + + real(kind=kind_noahmp) :: PhotosynTotal ! total leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: PhotosynLeafSunlit ! sunlit leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: PhotosynLeafShade ! shaded leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: PhotosynCrop ! crop photosynthesis rate [umol co2/m2/s] + real(kind=kind_noahmp) :: GrossPriProduction ! gross primary production [g/m2/s C] + real(kind=kind_noahmp) :: NetEcoExchange ! net ecosystem exchange [g/m2/s CO2] + real(kind=kind_noahmp) :: NetPriProductionTot ! total net primary production [g/m2/s C] + real(kind=kind_noahmp) :: NetPriProductionLeaf ! leaf net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionRoot ! root net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionWood ! wood net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionStem ! stem net primary production [g/m2/s] + real(kind=kind_noahmp) :: NetPriProductionGrain ! grain net primary production [g/m2/s] + real(kind=kind_noahmp) :: RespirationPlantTot ! total plant respiration (leaf,stem,root,wood,grain) [g/m2/s C] + real(kind=kind_noahmp) :: RespirationSoilOrg ! soil heterotrophic (organic) respiration [g/m2/s C] + real(kind=kind_noahmp) :: CarbonToAtmos ! carbon flux to atmosphere [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespLeaf ! growth respiration rate for leaf [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespRoot ! growth respiration rate for root [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespWood ! growth respiration rate for wood [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespStem ! growth respiration rate for stem [g/m2/s] + real(kind=kind_noahmp) :: GrowthRespGrain ! growth respiration rate for grain [g/m2/s] + real(kind=kind_noahmp) :: LeafMassMaxChg ! maximum leaf mass available to change [g/m2/s] + real(kind=kind_noahmp) :: StemMassMaxChg ! maximum stem mass available to change [g/m2/s] + real(kind=kind_noahmp) :: CarbonDecayToStable ! decay rate of fast carbon to slow carbon [g/m2/s] + real(kind=kind_noahmp) :: RespirationLeaf ! leaf respiration [umol CO2/m2/s] + real(kind=kind_noahmp) :: RespirationStem ! stem respiration [g/m2/s] + real(kind=kind_noahmp) :: RespirationWood ! wood respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationLeafMaint ! leaf maintenance respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationRoot ! fine root respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationSoil ! soil respiration rate [g/m2/s] + real(kind=kind_noahmp) :: RespirationGrain ! grain respiration rate [g/m2/s] + real(kind=kind_noahmp) :: ConvRootToGrain ! root to grain conversion [g/m2/s] + real(kind=kind_noahmp) :: ConvStemToGrain ! stem to grain conversion [g/m2/s] + real(kind=kind_noahmp) :: ConvLeafToGrain ! leaf to grain conversion [g/m2/s] + real(kind=kind_noahmp) :: TurnoverLeaf ! leaf turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverStem ! stem turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverWood ! wood turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverRoot ! root turnover rate [g/m2/s] + real(kind=kind_noahmp) :: TurnoverGrain ! grain turnover rate [g/m2/s] + real(kind=kind_noahmp) :: DeathLeaf ! death rate of leaf mass [g/m2/s] + real(kind=kind_noahmp) :: DeathStem ! death rate of stem mass [g/m2/s] + real(kind=kind_noahmp) :: CarbonAssim ! carbon assimilated rate [g/m2/s] + real(kind=kind_noahmp) :: CarbohydrAssim ! carbohydrate assimilated rate [g/m2/s] + + end type flux_type + + +!=== define "state" sub-type of biochem (biochem%state%variable) + type :: state_type + + integer :: PlantGrowStage ! plant growing stage + integer :: IndexPlanting ! Planting index (0=off, 1=on) + integer :: IndexHarvest ! Harvest index (0=on,1=off) + real(kind=kind_noahmp) :: IndexGrowSeason ! growing season index (0=off, 1=on) + real(kind=kind_noahmp) :: NitrogenConcFoliage ! foliage nitrogen concentration [%] + real(kind=kind_noahmp) :: LeafMass ! leaf mass [g/m2] + real(kind=kind_noahmp) :: RootMass ! mass of fine roots [g/m2] + real(kind=kind_noahmp) :: StemMass ! stem mass [g/m2] + real(kind=kind_noahmp) :: WoodMass ! mass of wood (include woody roots) [g/m2] + real(kind=kind_noahmp) :: GrainMass ! mass of grain [g/m2] + real(kind=kind_noahmp) :: CarbonMassDeepSoil ! stable carbon in deep soil [g/m2] + real(kind=kind_noahmp) :: CarbonMassShallowSoil ! short-lived carbon in shallow soil [g/m2] + real(kind=kind_noahmp) :: CarbonMassSoilTot ! total soil carbon mass [g/m2 C] + real(kind=kind_noahmp) :: CarbonMassLiveTot ! total living carbon mass ([g/m2 C] + real(kind=kind_noahmp) :: LeafAreaPerMass ! leaf area per unit mass [m2/g] + real(kind=kind_noahmp) :: StemAreaPerMass ! stem area per unit mass (m2/g) + real(kind=kind_noahmp) :: LeafMassMin ! minimum leaf mass [g/m2] + real(kind=kind_noahmp) :: StemMassMin ! minimum stem mass [g/m2] + real(kind=kind_noahmp) :: CarbonFracToLeaf ! fraction of carbon flux allocated to leaves + real(kind=kind_noahmp) :: CarbonFracToRoot ! fraction of carbon flux allocated to roots + real(kind=kind_noahmp) :: CarbonFracToWood ! fraction of carbon flux allocated to wood + real(kind=kind_noahmp) :: CarbonFracToStem ! fraction of carbon flux allocated to stem + real(kind=kind_noahmp) :: WoodCarbonFrac ! wood carbon fraction in (root + wood) carbon + real(kind=kind_noahmp) :: CarbonFracToWoodRoot ! fraction of carbon to root and wood + real(kind=kind_noahmp) :: MicroRespFactorSoilWater ! soil water factor for microbial respiration + real(kind=kind_noahmp) :: MicroRespFactorSoilTemp ! soil temperature factor for microbial respiration + real(kind=kind_noahmp) :: RespFacNitrogenFoliage ! foliage nitrogen adjustemt factor to respiration (<= 1) + real(kind=kind_noahmp) :: RespFacTemperature ! temperature factor for respiration + real(kind=kind_noahmp) :: RespReductionFac ! respiration reduction factor (<= 1) + real(kind=kind_noahmp) :: GrowDegreeDay ! growing degree days + + end type state_type + + +!=== define "parameter" sub-type of biochem (biochem%param%variable) + type :: parameter_type + + integer :: DatePlanting ! planting date + integer :: DateHarvest ! harvest date + real(kind=kind_noahmp) :: QuantumEfficiency25C ! quantum efficiency at 25c [umol CO2/umol photon] + real(kind=kind_noahmp) :: CarboxylRateMax25C ! maximum rate of carboxylation at 25c [umol CO2/m2/s] + real(kind=kind_noahmp) :: CarboxylRateMaxQ10 ! change in maximum rate of carboxylation for every 10-deg C temperature change + real(kind=kind_noahmp) :: PhotosynPathC3 ! C3 photosynthetic pathway indicator: 0.0 = c4, 1.0 = c3 + real(kind=kind_noahmp) :: SlopeConductToPhotosyn ! slope of conductance-to-photosynthesis relationship + real(kind=kind_noahmp) :: TemperatureMinPhotosyn ! minimum temperature for photosynthesis [K] + real(kind=kind_noahmp) :: LeafAreaPerMass1side ! single-side leaf area per mass [m2/kg] + real(kind=kind_noahmp) :: NitrogenConcFoliageMax ! foliage nitrogen concentration when f(n)=1 (%) + real(kind=kind_noahmp) :: WoodToRootRatio ! wood to root ratio + real(kind=kind_noahmp) :: WoodPoolIndex ! wood pool index (0~1) depending on woody or not + real(kind=kind_noahmp) :: TurnoverCoeffLeafVeg ! leaf turnover coefficient [1/s] for generic vegetation + real(kind=kind_noahmp) :: LeafDeathWaterCoeffVeg ! coeficient for leaf water stress death [1/s] for generic vegetation + real(kind=kind_noahmp) :: LeafDeathTempCoeffVeg ! coeficient for leaf temperature stress death [1/s] for generic vegetation + real(kind=kind_noahmp) :: MicroRespCoeff ! microbial respiration coefficient [umol co2 /kg c/ s] + real(kind=kind_noahmp) :: RespMaintQ10 ! change in maintenance respiration for every 10-deg C temperature change + real(kind=kind_noahmp) :: RespMaintLeaf25C ! leaf maintenance respiration at 25C [umol CO2/m2 /s] + real(kind=kind_noahmp) :: RespMaintStem25C ! stem maintenance respiration at 25C [umol CO2/kg bio/s], bio: C or CH2O + real(kind=kind_noahmp) :: RespMaintRoot25C ! root maintenance respiration at 25C [umol CO2/kg bio/s], bio: C or CH2O + real(kind=kind_noahmp) :: RespMaintGrain25C ! grain maintenance respiration at 25C [umol CO2/kg bio/s], bio: C or CH2O + real(kind=kind_noahmp) :: GrowthRespFrac ! fraction of growth respiration + real(kind=kind_noahmp) :: TemperaureLeafFreeze ! characteristic temperature for leaf freezing [K] + real(kind=kind_noahmp) :: LeafAreaPerBiomass ! leaf area per living leaf biomass [m2/g] + real(kind=kind_noahmp) :: TempBaseGrowDegDay ! Base temperature for growing degree day (GDD) accumulation [C] + real(kind=kind_noahmp) :: TempMaxGrowDegDay ! Maximum temperature for growing degree day (GDD) accumulation [C] + real(kind=kind_noahmp) :: GrowDegDayEmerg ! growing degree day (GDD) from seeding to emergence + real(kind=kind_noahmp) :: GrowDegDayInitVeg ! growing degree day (GDD) from seeding to initial vegetative + real(kind=kind_noahmp) :: GrowDegDayPostVeg ! growing degree day (GDD) from seeding to post vegetative + real(kind=kind_noahmp) :: GrowDegDayInitReprod ! growing degree day (GDD) from seeding to intial reproductive + real(kind=kind_noahmp) :: GrowDegDayMature ! growing degree day (GDD) from seeding to pysical maturity + real(kind=kind_noahmp) :: PhotosynRadFrac ! Fraction of incoming solar radiation to photosynthetically active radiation + real(kind=kind_noahmp) :: TempMinCarbonAssim ! Minimum temperature for CO2 assimulation [C] + real(kind=kind_noahmp) :: TempMaxCarbonAssim ! CO2 assimulation linearly increasing until reaching this temperature [C] + real(kind=kind_noahmp) :: TempMaxCarbonAssimMax ! CO2 assmilation rate remain at CarbonAssimRefMax until reaching this temperature [C] + real(kind=kind_noahmp) :: CarbonAssimRefMax ! reference maximum CO2 assimilation rate [g co2/m2/s] + real(kind=kind_noahmp) :: LightExtCoeff ! light extinction coefficient + real(kind=kind_noahmp) :: LightUseEfficiency ! initial light use efficiency + real(kind=kind_noahmp) :: CarbonAssimReducFac ! CO2 assimilation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + real(kind=kind_noahmp) :: StemAreaIndexMin ! minimum stem area index [m2/m2] + real(kind=kind_noahmp) :: WoodAllocFac ! present wood allocation factor + real(kind=kind_noahmp) :: WaterStressCoeff ! water stress coeficient + real(kind=kind_noahmp) :: LeafAreaIndexMin ! minimum leaf area index [m2/m2] + real(kind=kind_noahmp) :: TurnoverCoeffRootVeg ! root turnover coefficient [1/s] for generic vegetation + real(kind=kind_noahmp) :: WoodRespCoeff ! wood respiration coeficient [1/s] + + real(kind=kind_noahmp), allocatable, dimension(:) :: LeafDeathTempCoeffCrop ! coeficient for leaf temperature stress death [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: LeafDeathWaterCoeffCrop ! coeficient for leaf water stress death [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrLeafToGrain ! fraction of carbohydrate flux transallocate from leaf to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrStemToGrain ! fraction of carbohydrate flux transallocate from stem to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrRootToGrain ! fraction of carbohydrate flux transallocate from root to grain + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToLeaf ! fraction of carbohydrate flux to leaf for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToStem ! fraction of carbohydrate flux to stem for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToRoot ! fraction of carbohydrate flux to root for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: CarbohydrFracToGrain ! fraction of carbohydrate flux to grain for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: TurnoverCoeffLeafCrop ! leaf turnover coefficient [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: TurnoverCoeffStemCrop ! stem turnover coefficient [1/s] for crop + real(kind=kind_noahmp), allocatable, dimension(:) :: TurnoverCoeffRootCrop ! root tunrover coefficient [1/s] for crop + + end type parameter_type + + +!=== define biochem type that includes 3 subtypes (flux,state,parameter) + type, public :: biochem_type + + type(flux_type) :: flux + type(state_type) :: state + type(parameter_type) :: param + + end type biochem_type + +end module BiochemVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CanopyHydrologyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CanopyHydrologyMod.F90 new file mode 100644 index 0000000000..24fab3b4be --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CanopyHydrologyMod.F90 @@ -0,0 +1,141 @@ +module CanopyHydrologyMod + +!!! Canopy Hydrology processes for intercepted rain and snow water +!!! Canopy liquid water evaporation and dew; canopy ice water sublimation and frost + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CanopyHydrology(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CANWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + HeatLatentCanopy => noahmp%energy%flux%HeatLatentCanopy ,& ! in, canopy latent heat flux [W/m2] (+ to atm) + HeatLatentTransp => noahmp%energy%flux%HeatLatentTransp ,& ! in, latent heat flux from transpiration [W/m2] (+ to atm) + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + FlagFrozenCanopy => noahmp%energy%state%FlagFrozenCanopy ,& ! in, used to define latent heat pathway + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + SnowfallDensity => noahmp%water%state%SnowfallDensity ,& ! in, bulk density of snowfall [kg/m3] + CanopyLiqHoldCap => noahmp%water%param%CanopyLiqHoldCap ,& ! in, maximum intercepted liquid water per unit veg area index [mm] + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! inout, intercepted canopy liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! inout, intercepted canopy ice [mm] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! inout, vegetation temperature [K] + CanopyTotalWater => noahmp%water%state%CanopyTotalWater ,& ! out, total canopy intercepted water [mm] + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! out, wetted or snowed fraction of the canopy + CanopyIceMax => noahmp%water%state%CanopyIceMax ,& ! out, canopy capacity for snow interception [mm] + CanopyLiqWaterMax => noahmp%water%state%CanopyLiqWaterMax ,& ! out, canopy capacity for rain interception [mm] + EvapCanopyNet => noahmp%water%flux%EvapCanopyNet ,& ! out, evaporation of intercepted total water [mm/s] + Transpiration => noahmp%water%flux%Transpiration ,& ! out, transpiration rate [mm/s] + EvapCanopyLiq => noahmp%water%flux%EvapCanopyLiq ,& ! out, canopy liquid water evaporation rate [mm/s] + DewCanopyLiq => noahmp%water%flux%DewCanopyLiq ,& ! out, canopy liquid water dew rate [mm/s] + FrostCanopyIce => noahmp%water%flux%FrostCanopyIce ,& ! out, canopy ice frost rate [mm/s] + SublimCanopyIce => noahmp%water%flux%SublimCanopyIce ,& ! out, canopy ice sublimation rate [mm/s] + MeltCanopyIce => noahmp%water%flux%MeltCanopyIce ,& ! out, canopy ice melting rate [mm/s] + FreezeCanopyLiq => noahmp%water%flux%FreezeCanopyLiq & ! out, canopy water freezing rate [mm/s] + ) +! -------------------------------------------------------------------- + + ! initialization for out-only variables + EvapCanopyNet = 0.0 + Transpiration = 0.0 + EvapCanopyLiq = 0.0 + DewCanopyLiq = 0.0 + FrostCanopyIce = 0.0 + SublimCanopyIce = 0.0 + MeltCanopyIce = 0.0 + FreezeCanopyLiq = 0.0 + CanopyLiqWaterMax = 0.0 + CanopyIceMax = 0.0 + CanopyWetFrac = 0.0 + CanopyTotalWater = 0.0 + + ! canopy liquid water + ! maximum canopy intercepted water + CanopyLiqWaterMax = VegFrac * CanopyLiqHoldCap * (LeafAreaIndEff + StemAreaIndEff) + + ! canopy evaporation, transpiration, and dew + if ( FlagFrozenCanopy .eqv. .false. ) then ! Barlage: change to FlagFrozenCanopy + Transpiration = max( HeatLatentTransp/ConstLatHeatEvap, 0.0 ) + EvapCanopyLiq = max( HeatLatentCanopy/ConstLatHeatEvap, 0.0 ) + DewCanopyLiq = abs( min( HeatLatentCanopy/ConstLatHeatEvap, 0.0 ) ) + SublimCanopyIce = 0.0 + FrostCanopyIce = 0.0 + else + Transpiration = max( HeatLatentTransp/ConstLatHeatSublim, 0.0 ) + EvapCanopyLiq = 0.0 + DewCanopyLiq = 0.0 + SublimCanopyIce = max( HeatLatentCanopy/ConstLatHeatSublim, 0.0 ) + FrostCanopyIce = abs( min( HeatLatentCanopy/ConstLatHeatSublim, 0.0 ) ) + endif + + ! canopy water balance. for convenience allow dew to bring CanopyLiqWater above + ! maxh2o or else would have to re-adjust drip + EvapCanopyLiq = min( CanopyLiqWater/MainTimeStep, EvapCanopyLiq ) + CanopyLiqWater = max( 0.0, CanopyLiqWater+(DewCanopyLiq-EvapCanopyLiq)*MainTimeStep ) + if ( CanopyLiqWater <= 1.0e-06 ) CanopyLiqWater = 0.0 + + ! canopy ice + ! maximum canopy intercepted ice + CanopyIceMax = VegFrac * 6.6 * (0.27 + 46.0/SnowfallDensity) * (LeafAreaIndEff + StemAreaIndEff) + + ! canopy sublimation and frost + SublimCanopyIce = min( CanopyIce/MainTimeStep, SublimCanopyIce ) + CanopyIce = max( 0.0, CanopyIce+(FrostCanopyIce-SublimCanopyIce)*MainTimeStep ) + if ( CanopyIce <= 1.0e-6 ) CanopyIce = 0.0 + + ! wetted fraction of canopy + if ( (CanopyIce > 0.0) .and. (CanopyIce >= CanopyLiqWater) ) then + CanopyWetFrac = max(0.0,CanopyIce) / max(CanopyIceMax,1.0e-06) + else + CanopyWetFrac = max(0.0,CanopyLiqWater) / max(CanopyLiqWaterMax,1.0e-06) + endif + CanopyWetFrac = min(CanopyWetFrac, 1.0) ** 0.667 + CanopyTotalWater = CanopyLiqWater + CanopyIce + + ! phase change + ! canopy ice melting + if ( (CanopyIce > 1.0e-6) .and. (TemperatureCanopy > ConstFreezePoint) ) then + MeltCanopyIce = min( CanopyIce/MainTimeStep, (TemperatureCanopy-ConstFreezePoint) * ConstHeatCapacIce * & + CanopyIce / ConstDensityIce / (MainTimeStep*ConstLatHeatFusion) ) + CanopyIce = max( 0.0, CanopyIce - MeltCanopyIce*MainTimeStep ) + CanopyLiqWater = max( 0.0, CanopyTotalWater - CanopyIce ) + TemperatureCanopy = CanopyWetFrac*ConstFreezePoint + (1.0 - CanopyWetFrac)*TemperatureCanopy + endif + + ! canopy water refreeezing + if ( (CanopyLiqWater > 1.0e-6) .and. (TemperatureCanopy < ConstFreezePoint) ) then + FreezeCanopyLiq = min( CanopyLiqWater/MainTimeStep, (ConstFreezePoint-TemperatureCanopy) * ConstHeatCapacWater * & + CanopyLiqWater / ConstDensityWater / (MainTimeStep*ConstLatHeatFusion) ) + CanopyLiqWater = max( 0.0, CanopyLiqWater - FreezeCanopyLiq*MainTimeStep ) + CanopyIce = max( 0.0, CanopyTotalWater - CanopyLiqWater ) + TemperatureCanopy = CanopyWetFrac*ConstFreezePoint + (1.0 - CanopyWetFrac)*TemperatureCanopy + endif + + ! update total canopy water + CanopyTotalWater = CanopyLiqWater + CanopyIce + + ! total canopy net evaporation + EvapCanopyNet = EvapCanopyLiq + SublimCanopyIce - DewCanopyLiq - FrostCanopyIce + + end associate + + end subroutine CanopyHydrology + +end module CanopyHydrologyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CanopyRadiationTwoStreamMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CanopyRadiationTwoStreamMod.F90 new file mode 100644 index 0000000000..cbafc5c115 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CanopyRadiationTwoStreamMod.F90 @@ -0,0 +1,263 @@ +module CanopyRadiationTwoStreamMod + +!!! Compute canopy radiative transfer using two-stream approximation of Dickinson (1983) Adv Geophysics +!!! Calculate fluxes absorbed by vegetation, reflected by vegetation, and transmitted through vegetation +!!! for unit incoming direct or diffuse flux given an underlying ground with known albedo. +!!! Reference for the modified two-stream scheme Niu and Yang (2004), JGR + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CanopyRadiationTwoStream(noahmp, IndSwBnd, IndSwDif) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: TWOSTREAM +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + integer , intent(in ) :: IndSwBnd ! solar radiation band index + integer , intent(in ) :: IndSwDif ! 0=unit incoming direct; 1=unit incoming diffuse + +! local variables + real(kind=kind_noahmp) :: ScatCoeffCan ! total scattering coefficient for canopy + real(kind=kind_noahmp) :: ScatCoeffLeaf ! scattering coefficient for leaves not covered by snow + real(kind=kind_noahmp) :: UpscatCoeffCanDif ! upscatter parameter for diffuse radiation + real(kind=kind_noahmp) :: UpscatCoeffLeafDif ! upscatter parameter for diffuse radiation for leaves + real(kind=kind_noahmp) :: UpscatCoeffCanDir ! upscatter parameter for direct radiation + real(kind=kind_noahmp) :: UpscatCoeffLeafDir ! upscatter parameter for direct radiation for leaves + real(kind=kind_noahmp) :: OpticDepthDir ! optical depth of direct beam per unit leaf area + real(kind=kind_noahmp) :: OpticDepthDif ! average diffuse optical depth per unit leaf area + real(kind=kind_noahmp) :: CosSolarZenithAngleTmp ! cosine of solar zenith angle (0.001~1.0) + real(kind=kind_noahmp) :: SingleScatAlb ! single scattering albedo + real(kind=kind_noahmp) :: LeafOrientIndex ! leaf orientation index (-0.4~0.6) + real(kind=kind_noahmp) :: RadSwTransDir ! transmitted direct solar radiation below canopy + real(kind=kind_noahmp) :: RadSwTransDif ! transmitted diffuse solar radiation below canopy + real(kind=kind_noahmp) :: RadSwReflTot ! total reflected flux by canopy and ground + real(kind=kind_noahmp) :: VegDensity ! vegetation density + real(kind=kind_noahmp) :: RadSwReflCan ! reflected flux by canopy + real(kind=kind_noahmp) :: RadSwReflGrd ! reflected flux by ground + real(kind=kind_noahmp) :: CrownDepth ! crown depth [m] + real(kind=kind_noahmp) :: CrownRadiusVert ! vertical crown radius [m] + real(kind=kind_noahmp) :: SolarAngleTmp ! solar angle conversion from SZA + real(kind=kind_noahmp) :: FoliageDensity ! foliage volume density (m-1) + real(kind=kind_noahmp) :: VegAreaIndTmp ! temporary effective VAI + real(kind=kind_noahmp) :: Tmp0,Tmp1,Tmp2,Tmp3,Tmp4 ! temporary vars + real(kind=kind_noahmp) :: Tmp5,Tmp6,Tmp7,Tmp8,Tmp9 ! temporary vars + real(kind=kind_noahmp) :: P1,P2,P3,P4,S1,S2,U1,U2,U3 ! temporary vars + real(kind=kind_noahmp) :: B,C,D,D1,D2,F,H,H1,H2,H3 ! temporary vars + real(kind=kind_noahmp) :: H4,H5,H6,H7,H8,H9,H10 ! temporary vars + real(kind=kind_noahmp) :: Phi1,Phi2,Sigma ! temporary vars + +! -------------------------------------------------------------------- + associate( & + OptCanopyRadiationTransfer => noahmp%config%nmlist%OptCanopyRadiationTransfer ,& ! in, options for canopy radiation transfer + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! in, wetted or snowed fraction of the canopy + TreeCrownRadius => noahmp%energy%param%TreeCrownRadius ,& ! in, tree crown radius [m] + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + HeightCanopyBot => noahmp%energy%param%HeightCanopyBot ,& ! in, bottom of canopy [m] + TreeDensity => noahmp%energy%param%TreeDensity ,& ! in, tree density [no. of trunks per m2] + CanopyOrientIndex => noahmp%energy%param%CanopyOrientIndex ,& ! in, leaf/stem orientation index + ScatterCoeffSnow => noahmp%energy%param%ScatterCoeffSnow ,& ! in, Scattering coefficient for snow + UpscatterCoeffSnowDir => noahmp%energy%param%UpscatterCoeffSnowDir ,& ! in, Upscattering parameters for snow for direct radiation + UpscatterCoeffSnowDif => noahmp%energy%param%UpscatterCoeffSnowDif ,& ! in, Upscattering parameters for snow for diffuse radiation + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! in, one-sided leaf+stem area index [m2/m2] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! in, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! in, ground albedo (diffuse: vis, nir) + ReflectanceVeg => noahmp%energy%state%ReflectanceVeg ,& ! in, leaf/stem reflectance weighted by LAI and SAI fraction + TransmittanceVeg => noahmp%energy%state%TransmittanceVeg ,& ! in, leaf/stem transmittance weighted by LAI and SAI fraction + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! out, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif ,& ! out, surface albedo (diffuse) + VegAreaProjDir => noahmp%energy%state%VegAreaProjDir ,& ! out, projected leaf+stem area in solar direction + GapBtwCanopy => noahmp%energy%state%GapBtwCanopy ,& ! out, between canopy gap fraction for beam + GapInCanopy => noahmp%energy%state%GapInCanopy ,& ! out, within canopy gap fraction for beam + GapCanopyDif => noahmp%energy%state%GapCanopyDif ,& ! out, gap fraction for diffue light + GapCanopyDir => noahmp%energy%state%GapCanopyDir ,& ! out, total gap fraction for beam (<=1-VegFrac) + RadSwAbsVegDir => noahmp%energy%flux%RadSwAbsVegDir ,& ! out, flux abs by veg (per unit direct flux) + RadSwAbsVegDif => noahmp%energy%flux%RadSwAbsVegDif ,& ! out, flux abs by veg (per unit diffuse flux) + RadSwDirTranGrdDir => noahmp%energy%flux%RadSwDirTranGrdDir ,& ! out, downward direct flux below veg (per unit dir flux) + RadSwDirTranGrdDif => noahmp%energy%flux%RadSwDirTranGrdDif ,& ! out, downward direct flux below veg per unit dif flux (=0) + RadSwDifTranGrdDir => noahmp%energy%flux%RadSwDifTranGrdDir ,& ! out, downward diffuse flux below veg (per unit dir flux) + RadSwDifTranGrdDif => noahmp%energy%flux%RadSwDifTranGrdDif ,& ! out, downward diffuse flux below veg (per unit dif flux) + RadSwReflVegDir => noahmp%energy%flux%RadSwReflVegDir ,& ! out, flux reflected by veg layer (per unit direct flux) + RadSwReflVegDif => noahmp%energy%flux%RadSwReflVegDif ,& ! out, flux reflected by veg layer (per unit diffuse flux) + RadSwReflGrdDir => noahmp%energy%flux%RadSwReflGrdDir ,& ! out, flux reflected by ground (per unit direct flux) + RadSwReflGrdDif => noahmp%energy%flux%RadSwReflGrdDif & ! out, flux reflected by ground (per unit diffuse flux) + ) +! ---------------------------------------------------------------------- + + ! compute within and between gaps + if ( VegAreaIndEff == 0.0 ) then + GapCanopyDir = 1.0 + GapCanopyDif = 1.0 + else + if ( OptCanopyRadiationTransfer == 1 ) then + VegDensity = -log(max(1.0-VegFrac, 0.01)) / (ConstPI*TreeCrownRadius**2) + CrownDepth = HeightCanopyTop - HeightCanopyBot + CrownRadiusVert = 0.5 * CrownDepth + SolarAngleTmp = atan(CrownRadiusVert / TreeCrownRadius * tan(acos(max(0.01, CosSolarZenithAngle)))) + !GapBtwCanopy = exp(TreeDensity * ConstPI * TreeCrownRadius**2 / cos(SolarAngleTmp)) + GapBtwCanopy = exp(-VegDensity * ConstPI * TreeCrownRadius**2 / cos(SolarAngleTmp)) + FoliageDensity = VegAreaIndEff / (1.33*ConstPI*TreeCrownRadius**3.0 * (CrownRadiusVert/TreeCrownRadius)*VegDensity) + VegAreaIndTmp = CrownDepth * FoliageDensity + GapInCanopy = (1.0 - GapBtwCanopy) * exp(-0.5*VegAreaIndTmp/CosSolarZenithAngle) + GapCanopyDir = min( 1.0-VegFrac, GapBtwCanopy+GapInCanopy ) + GapCanopyDif = 0.05 + endif + if ( OptCanopyRadiationTransfer == 2 ) then + GapCanopyDir = 0.0 + GapCanopyDif = 0.0 + endif + if ( OptCanopyRadiationTransfer == 3 ) then + GapCanopyDir = 1.0 - VegFrac + GapCanopyDif = 1.0 - VegFrac + endif + endif + + ! calculate two-stream parameters ScatCoeffCan, UpscatCoeffCanDir, UpscatCoeffCanDif, OpticDepthDif, VegAreaProjDir, OpticDepthDir. + ! ScatCoeffCan, UpscatCoeffCanDir, UpscatCoeffCanDif are adjusted for snow. values for ScatCoeffCan*UpscatCoeffCanDir + ! and ScatCoeffCan*UpscatCoeffCanDif are calculated and then divided by the new ScatCoeffCan + ! because the product ScatCoeffCan*UpscatCoeffCanDif, ScatCoeffCan*UpscatCoeffCanDir is used in solution. + ! also, the transmittances and reflectances are linear + ! weights of leaf and stem values. + + CosSolarZenithAngleTmp = max( 0.001, CosSolarZenithAngle ) + LeafOrientIndex = min( max(CanopyOrientIndex, -0.4), 0.6 ) + if ( abs(LeafOrientIndex) <= 0.01 ) LeafOrientIndex = 0.01 + Phi1 = 0.5 - 0.633 * LeafOrientIndex - 0.330 * LeafOrientIndex * LeafOrientIndex + Phi2 = 0.877 * (1.0 - 2.0 * Phi1) + VegAreaProjDir = Phi1 + Phi2 * CosSolarZenithAngleTmp + OpticDepthDir = VegAreaProjDir / CosSolarZenithAngleTmp + OpticDepthDif = (1.0 - Phi1/Phi2 * log( (Phi1+Phi2) / Phi1 )) / Phi2 + ScatCoeffLeaf = ReflectanceVeg(IndSwBnd) + TransmittanceVeg(IndSwBnd) + Tmp0 = VegAreaProjDir + Phi2 * CosSolarZenithAngleTmp + Tmp1 = Phi1 * CosSolarZenithAngleTmp + SingleScatAlb = 0.5 * ScatCoeffLeaf * VegAreaProjDir / Tmp0 * (1.0 - Tmp1/Tmp0 * log((Tmp1+Tmp0)/Tmp1) ) + UpscatCoeffLeafDir = (1.0 + OpticDepthDif * OpticDepthDir) / & + (ScatCoeffLeaf * OpticDepthDif * OpticDepthDir) * SingleScatAlb + UpscatCoeffLeafDif = 0.5 * (ReflectanceVeg(IndSwBnd) + TransmittanceVeg(IndSwBnd) + & + (ReflectanceVeg(IndSwBnd)-TransmittanceVeg(IndSwBnd))*((1.0+LeafOrientIndex)/2.0)**2)/ScatCoeffLeaf + + ! adjust omega, betad, and betai for intercepted snow + if ( TemperatureCanopy > ConstFreezePoint ) then ! no snow on leaf + Tmp0 = ScatCoeffLeaf + Tmp1 = UpscatCoeffLeafDir + Tmp2 = UpscatCoeffLeafDif + else + Tmp0 = (1.0 - CanopyWetFrac) * ScatCoeffLeaf + CanopyWetFrac * ScatterCoeffSnow(IndSwBnd) + Tmp1 = ((1.0 - CanopyWetFrac) * ScatCoeffLeaf * UpscatCoeffLeafDir + & + CanopyWetFrac * ScatterCoeffSnow(IndSwBnd) * UpscatterCoeffSnowDir ) / Tmp0 ! direct + Tmp2 = ((1.0 - CanopyWetFrac) * ScatCoeffLeaf * UpscatCoeffLeafDif + & + CanopyWetFrac * ScatterCoeffSnow(IndSwBnd) * UpscatterCoeffSnowDif ) / Tmp0 ! diffuse + endif + ScatCoeffCan = Tmp0 + UpscatCoeffCanDir = Tmp1 + UpscatCoeffCanDif = Tmp2 + + ! absorbed, reflected, transmitted fluxes per unit incoming radiation + B = 1.0 - ScatCoeffCan + ScatCoeffCan * UpscatCoeffCanDif + C = ScatCoeffCan * UpscatCoeffCanDif + Tmp0 = OpticDepthDif * OpticDepthDir + D = Tmp0 * ScatCoeffCan * UpscatCoeffCanDir + F = Tmp0 * ScatCoeffCan * (1.0 - UpscatCoeffCanDir) + Tmp1 = B * B - C * C + H = sqrt(Tmp1) / OpticDepthDif + Sigma = Tmp0 * Tmp0 - Tmp1 + if ( abs(Sigma) < 1.0e-6 ) Sigma = sign(1.0e-6, Sigma) + P1 = B + OpticDepthDif * H + P2 = B - OpticDepthDif * H + P3 = B + Tmp0 + P4 = B - Tmp0 + S1 = exp( -H * VegAreaIndEff ) + S2 = exp( -OpticDepthDir * VegAreaIndEff ) + if ( IndSwDif == 0 ) then ! direct + U1 = B - C / AlbedoGrdDir(IndSwBnd) + U2 = B - C * AlbedoGrdDir(IndSwBnd) + U3 = F + C * AlbedoGrdDir(IndSwBnd) + else ! diffuse + U1 = B - C / AlbedoGrdDif(IndSwBnd) + U2 = B - C * AlbedoGrdDif(IndSwBnd) + U3 = F + C * AlbedoGrdDif(IndSwBnd) + endif + Tmp2 = U1 - OpticDepthDif * H + Tmp3 = U1 + OpticDepthDif * H + D1 = P1 * Tmp2 / S1 - P2 * Tmp3 * S1 + Tmp4 = U2 + OpticDepthDif * H + Tmp5 = U2 - OpticDepthDif * H + D2 = Tmp4 / S1 - Tmp5 * S1 + H1 = -D * P4 - C * F + Tmp6 = D - H1 * P3 / Sigma + Tmp7 = ( D - C - H1 / Sigma * (U1+Tmp0) ) * S2 + H2 = ( Tmp6 * Tmp2 / S1 - P2 * Tmp7 ) / D1 + H3 = - ( Tmp6 * Tmp3 * S1 - P1 * Tmp7 ) / D1 + H4 = -F * P3 - C * D + Tmp8 = H4 / Sigma + Tmp9 = ( U3 - Tmp8 * (U2-Tmp0) ) * S2 + H5 = - ( Tmp8 * Tmp4 / S1 + Tmp9 ) / D2 + H6 = ( Tmp8 * Tmp5 * S1 + Tmp9 ) / D2 + H7 = (C * Tmp2) / (D1 * S1) + H8 = (-C * Tmp3 * S1) / D1 + H9 = Tmp4 / (D2 * S1) + H10 = (-Tmp5 * S1) / D2 + + ! downward direct and diffuse fluxes below vegetation Niu and Yang (2004), JGR. + if ( IndSwDif == 0 ) then ! direct + RadSwTransDir = S2 * (1.0 - GapCanopyDir) + GapCanopyDir + RadSwTransDif = (H4 * S2 / Sigma + H5 * S1 + H6 / S1) * (1.0 - GapCanopyDir) + else ! diffuse + RadSwTransDir = 0.0 + RadSwTransDif = (H9 * S1 + H10 / S1) * (1.0 - GapCanopyDif) + GapCanopyDif + endif + if ( IndSwDif == 0 ) then ! direct + RadSwDirTranGrdDir(IndSwBnd) = RadSwTransDir + RadSwDifTranGrdDir(IndSwBnd) = RadSwTransDif + else ! diffuse + RadSwDirTranGrdDif(IndSwBnd) = RadSwTransDir + RadSwDifTranGrdDif(IndSwBnd) = RadSwTransDif + endif + + ! flux reflected by the surface (veg. and ground) + if ( IndSwDif == 0 ) then ! direct + RadSwReflTot = (H1 / Sigma + H2 + H3) * (1.0 - GapCanopyDir) + AlbedoGrdDir(IndSwBnd) * GapCanopyDir + RadSwReflCan = (H1 / Sigma + H2 + H3) * (1.0 - GapCanopyDir) + RadSwReflGrd = AlbedoGrdDir(IndSwBnd) * GapCanopyDir + else ! diffuse + RadSwReflTot = (H7 + H8) * (1.0 - GapCanopyDif) + AlbedoGrdDif(IndSwBnd) * GapCanopyDif + RadSwReflCan = (H7 + H8) * (1.0 - GapCanopyDif) + AlbedoGrdDif(IndSwBnd) * GapCanopyDif + RadSwReflGrd = 0 + endif + if ( IndSwDif == 0 ) then ! direct + AlbedoSfcDir(IndSwBnd) = RadSwReflTot + RadSwReflVegDir(IndSwBnd) = RadSwReflCan + RadSwReflGrdDir(IndSwBnd) = RadSwReflGrd + else ! diffuse + AlbedoSfcDif(IndSwBnd) = RadSwReflTot + RadSwReflVegDif(IndSwBnd) = RadSwReflCan + RadSwReflGrdDif(IndSwBnd) = RadSwReflGrd + endif + + ! flux absorbed by vegetation + if ( IndSwDif == 0 ) then ! direct + RadSwAbsVegDir(IndSwBnd) = 1.0 - AlbedoSfcDir(IndSwBnd) - (1.0 - AlbedoGrdDir(IndSwBnd))*RadSwDirTranGrdDir(IndSwBnd) - & + (1.0 - AlbedoGrdDif(IndSwBnd))*RadSwDifTranGrdDir(IndSwBnd) + else ! diffuse + RadSwAbsVegDif(IndSwBnd) = 1.0 - AlbedoSfcDif(IndSwBnd) - (1.0 - AlbedoGrdDir(IndSwBnd))*RadSwDirTranGrdDif(IndSwBnd) - & + (1.0 - AlbedoGrdDif(IndSwBnd))*RadSwDifTranGrdDif(IndSwBnd) + endif + + end associate + + end subroutine CanopyRadiationTwoStream + +end module CanopyRadiationTwoStreamMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CanopyWaterInterceptMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CanopyWaterInterceptMod.F90 new file mode 100644 index 0000000000..274d0c2604 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CanopyWaterInterceptMod.F90 @@ -0,0 +1,155 @@ +module CanopyWaterInterceptMod + +!!! Canopy water processes for snow and rain interception +!!! Subsequent hydrological process for intercepted water is done in CanopyHydrologyMod.F90 + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CanopyWaterIntercept(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PRECIP_HEAT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! The water and heat portions of PRECIP_HEAT are separated in refactored code +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: IceDripFacTemp ! temperature factor for unloading rate + real(kind=kind_noahmp) :: IceDripFacWind ! wind factor for unloading rate + real(kind=kind_noahmp) :: CanopySnowDrip ! canopy snow/ice unloading + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + CanopyLiqHoldCap => noahmp%water%param%CanopyLiqHoldCap ,& ! in, maximum intercepted liquid water per unit veg area index [mm] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! in, total liquid rainfall [mm/s] before interception + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! in, total snowfall [mm/s] before interception + SnowfallDensity => noahmp%water%state%SnowfallDensity ,& ! in, bulk density of snowfall [kg/m3] + PrecipAreaFrac => noahmp%water%state%PrecipAreaFrac ,& ! in, fraction of the gridcell that receives precipitation + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! inout, intercepted canopy liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! inout, intercepted canopy ice [mm] + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! out, wetted or snowed fraction of the canopy + CanopyTotalWater => noahmp%water%state%CanopyTotalWater ,& ! out, total canopy intercepted water [mm] + CanopyIceMax => noahmp%water%state%CanopyIceMax ,& ! out, canopy capacity for snow interception [mm] + CanopyLiqWaterMax => noahmp%water%state%CanopyLiqWaterMax ,& ! out, canopy capacity for rain interception [mm] + InterceptCanopyRain => noahmp%water%flux%InterceptCanopyRain ,& ! out, interception rate for rain [mm/s] + DripCanopyRain => noahmp%water%flux%DripCanopyRain ,& ! out, drip rate for intercepted rain [mm/s] + ThroughfallRain => noahmp%water%flux%ThroughfallRain ,& ! out, throughfall for rain [mm/s] + InterceptCanopySnow => noahmp%water%flux%InterceptCanopySnow ,& ! out, interception (loading) rate for snowfall [mm/s] + DripCanopySnow => noahmp%water%flux%DripCanopySnow ,& ! out, drip (unloading) rate for intercepted snow [mm/s] + ThroughfallSnow => noahmp%water%flux%ThroughfallSnow ,& ! out, throughfall of snowfall [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! out, rainfall at ground surface [mm/s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! out, snowfall at ground surface [mm/s] + SnowDepthIncr => noahmp%water%flux%SnowDepthIncr & ! out, snow depth increasing rate [m/s] due to snowfall + ) +! ---------------------------------------------------------------------- + + ! initialization + InterceptCanopyRain = 0.0 + DripCanopyRain = 0.0 + ThroughfallRain = 0.0 + InterceptCanopySnow = 0.0 + DripCanopySnow = 0.0 + ThroughfallSnow = 0.0 + RainfallGround = 0.0 + SnowfallGround = 0.0 + SnowDepthIncr = 0.0 + CanopySnowDrip = 0.0 + IceDripFacTemp = 0.0 + IceDripFacWind = 0.0 + + ! ----------------------- canopy liquid water ------------------------------ + ! maximum canopy water + CanopyLiqWaterMax = VegFrac * CanopyLiqHoldCap * (LeafAreaIndEff + StemAreaIndEff) + + ! average rain interception and throughfall + if ( (LeafAreaIndEff+StemAreaIndEff) > 0.0 ) then + InterceptCanopyRain = VegFrac * RainfallRefHeight * PrecipAreaFrac ! max interception capability + InterceptCanopyRain = min( InterceptCanopyRain, (CanopyLiqWaterMax-CanopyLiqWater)/MainTimeStep * & + (1.0-exp(-RainfallRefHeight*MainTimeStep/CanopyLiqWaterMax)) ) + InterceptCanopyRain = max( InterceptCanopyRain, 0.0 ) + DripCanopyRain = VegFrac * RainfallRefHeight - InterceptCanopyRain + ThroughfallRain = (1.0 - VegFrac) * RainfallRefHeight + CanopyLiqWater = max( 0.0, CanopyLiqWater + InterceptCanopyRain*MainTimeStep ) + else + InterceptCanopyRain = 0.0 + DripCanopyRain = 0.0 + ThroughfallRain = RainfallRefHeight + if ( CanopyLiqWater > 0.0 ) then ! canopy gets buried by rain + DripCanopyRain = DripCanopyRain + CanopyLiqWater / MainTimeStep + CanopyLiqWater = 0.0 + endif + endif + + ! ----------------------- canopy ice ------------------------------ + ! maximum canopy ice + CanopyIceMax = VegFrac * 6.6 * (0.27 + 46.0/SnowfallDensity) * (LeafAreaIndEff + StemAreaIndEff) + + ! average snow interception and throughfall + if ( (LeafAreaIndEff+StemAreaIndEff) > 0.0 ) then + InterceptCanopySnow = VegFrac * SnowfallRefHeight * PrecipAreaFrac + InterceptCanopySnow = min( InterceptCanopySnow, (CanopyIceMax-CanopyIce)/MainTimeStep * & + (1.0-exp(-SnowfallRefHeight*MainTimeStep/CanopyIceMax)) ) + InterceptCanopySnow = max( InterceptCanopySnow, 0.0 ) + IceDripFacTemp = max( 0.0, (TemperatureCanopy - 270.15) / 1.87e5 ) + IceDripFacWind = sqrt(WindEastwardRefHeight**2.0 + WindNorthwardRefHeight**2.0) / 1.56e5 + ! MB: changed below to reflect the rain assumption that all precip gets intercepted + CanopySnowDrip = max( 0.0, CanopyIce ) * (IceDripFacWind + IceDripFacTemp) + CanopySnowDrip = min( CanopyIce/MainTimeStep + InterceptCanopySnow, CanopySnowDrip) ! add constraint to keep water balance + DripCanopySnow = (VegFrac * SnowfallRefHeight - InterceptCanopySnow) + CanopySnowDrip + ThroughfallSnow = (1.0 - VegFrac) * SnowfallRefHeight + CanopyIce = max( 0.0, CanopyIce + (InterceptCanopySnow-CanopySnowDrip)*MainTimeStep ) + else + InterceptCanopySnow = 0.0 + DripCanopySnow = 0.0 + ThroughfallSnow = SnowfallRefHeight + if ( CanopyIce > 0.0 ) then ! canopy gets buried by snow + DripCanopySnow = DripCanopySnow + CanopyIce / MainTimeStep + CanopyIce = 0.0 + endif + endif + + ! wetted fraction of canopy + if ( CanopyIce > 0.0 ) then + CanopyWetFrac = max( 0.0, CanopyIce ) / max( CanopyIceMax, 1.0e-06 ) + else + CanopyWetFrac = max( 0.0, CanopyLiqWater ) / max( CanopyLiqWaterMax, 1.0e-06 ) + endif + CanopyWetFrac = min( CanopyWetFrac, 1.0 ) ** 0.667 + + ! total canopy water + CanopyTotalWater = CanopyLiqWater + CanopyIce + + ! rain or snow on the ground + RainfallGround = DripCanopyRain + ThroughfallRain + SnowfallGround = DripCanopySnow + ThroughfallSnow + SnowDepthIncr = SnowfallGround / SnowfallDensity + if ( (SurfaceType == 2) .and. (TemperatureGrd > ConstFreezePoint) ) then + SnowfallGround = 0.0 + SnowDepthIncr = 0.0 + endif + + end associate + + end subroutine CanopyWaterIntercept + +end module CanopyWaterInterceptMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxCropMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxCropMod.F90 new file mode 100644 index 0000000000..59f6ff10a2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxCropMod.F90 @@ -0,0 +1,268 @@ +module CarbonFluxCropMod + +!!! Main Carbon assimilation for crops +!!! based on RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 +!!! Modified by Xing Liu, 2014 + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CarbonFluxCrop(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CO2FLUX_CROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: DeathCoeffTemp ! temperature stress death coefficient + real(kind=kind_noahmp) :: DeathCoeffWater ! water stress death coefficient + real(kind=kind_noahmp) :: NetPriProdLeafAdd ! leaf assimil after resp. losses removed [gCH2O/m2/s] + real(kind=kind_noahmp) :: NetPriProdStemAdd ! stem assimil after resp. losses removed [gCH2O/m2/s] + !real(kind=kind_noahmp) :: RespTmp, Temp0 ! temperary vars for function below + !RespTmp(Temp0) = exp(0.08 * (Temp0 - 298.16)) ! Respiration as a function of temperature + +!------------------------------------------------------------------------ + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + WaterStressCoeff => noahmp%biochem%param%WaterStressCoeff ,& ! in, water stress coeficient + LeafAreaIndexMin => noahmp%biochem%param%LeafAreaIndexMin ,& ! in, minimum leaf area index [m2/m2] + StemAreaIndexMin => noahmp%biochem%param%StemAreaIndexMin ,& ! in, minimum stem area index [m2/m2] + NitrogenConcFoliageMax => noahmp%biochem%param%NitrogenConcFoliageMax ,& ! in, foliage nitrogen concentration when f(n)=1 [%] + RespMaintQ10 => noahmp%biochem%param%RespMaintQ10 ,& ! in, change in maintenance respiration for each 10C temp. change + RespMaintLeaf25C => noahmp%biochem%param%RespMaintLeaf25C ,& ! in, leaf maintenance respiration at 25C [umol CO2/m2/s] + RespMaintRoot25C => noahmp%biochem%param%RespMaintRoot25C ,& ! in, root maintenance respiration at 25C [umol CO2/kgCH2O/s] + RespMaintStem25C => noahmp%biochem%param%RespMaintStem25C ,& ! in, stem maintenance respiration at 25C [umol CO2/kgCH2O/s] + RespMaintGrain25C => noahmp%biochem%param%RespMaintGrain25C ,& ! in, grain maintenance respiration at 25C [umol CO2/kgCH2O/s] + GrowthRespFrac => noahmp%biochem%param%GrowthRespFrac ,& ! in, fraction of growth respiration + CarbohydrFracToLeaf => noahmp%biochem%param%CarbohydrFracToLeaf ,& ! in, fraction of carbohydrate flux to leaf + CarbohydrFracToStem => noahmp%biochem%param%CarbohydrFracToStem ,& ! in, fraction of carbohydrate flux to stem + CarbohydrFracToRoot => noahmp%biochem%param%CarbohydrFracToRoot ,& ! in, fraction of carbohydrate flux to root + CarbohydrFracToGrain => noahmp%biochem%param%CarbohydrFracToGrain ,& ! in, fraction of carbohydrate flux to grain + TurnoverCoeffLeafCrop => noahmp%biochem%param%TurnoverCoeffLeafCrop ,& ! in, leaf turnover coefficient [1/s] for crop + TurnoverCoeffRootCrop => noahmp%biochem%param%TurnoverCoeffRootCrop ,& ! in, root tunrover coefficient [1/s] for crop + TurnoverCoeffStemCrop => noahmp%biochem%param%TurnoverCoeffStemCrop ,& ! in, stem turnover coefficient [1/s] for crop + TemperaureLeafFreeze => noahmp%biochem%param%TemperaureLeafFreeze ,& ! in, characteristic temperature for leaf freezing [K] + LeafDeathWaterCoeffCrop => noahmp%biochem%param%LeafDeathWaterCoeffCrop ,& ! in, coeficient for water leaf stress death [1/s] for crop + LeafDeathTempCoeffCrop => noahmp%biochem%param%LeafDeathTempCoeffCrop ,& ! in, coeficient for temperature leaf stress death [1/s] for crop + CarbohydrLeafToGrain => noahmp%biochem%param%CarbohydrLeafToGrain ,& ! in, fraction of carbohydrate translocation from leaf to grain + CarbohydrStemToGrain => noahmp%biochem%param%CarbohydrStemToGrain ,& ! in, fraction of carbohydrate translocation from stem to grain + CarbohydrRootToGrain => noahmp%biochem%param%CarbohydrRootToGrain ,& ! in, fraction of carbohydrate translocation from root to grain + MicroRespCoeff => noahmp%biochem%param%MicroRespCoeff ,& ! in, microbial respiration parameter [umol CO2/kgC/s] + LeafAreaPerBiomass => noahmp%biochem%param%LeafAreaPerBiomass ,& ! in, leaf area per living leaf biomass [m2/g] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! in, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress ,& ! in, water stress coeficient (1.0 for wilting) + PhotosynTotal => noahmp%biochem%flux%PhotosynTotal ,& ! in, total leaf photosynthesis [umol CO2/m2/s] + NitrogenConcFoliage => noahmp%biochem%state%NitrogenConcFoliage ,& ! in, foliage nitrogen concentration [%] + IndexPlanting => noahmp%biochem%state%IndexPlanting ,& ! in, Planting index + PlantGrowStage => noahmp%biochem%state%PlantGrowStage ,& ! in, plant growing stage + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [gCH2O/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [gCH2O/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [gCH2O/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [gC/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [gC/m2] + GrainMass => noahmp%biochem%state%GrainMass ,& ! inout, mass of grain [gCH2O/m2] + RespFacNitrogenFoliage => noahmp%biochem%state%RespFacNitrogenFoliage ,& ! out, foliage nitrogen adjustemt to respiration (<= 1) + MicroRespFactorSoilWater => noahmp%biochem%state%MicroRespFactorSoilWater ,& ! out, soil water factor for microbial respiration + MicroRespFactorSoilTemp => noahmp%biochem%state%MicroRespFactorSoilTemp ,& ! out, soil temperature factor for microbial respiration + LeafMassMin => noahmp%biochem%state%LeafMassMin ,& ! out, minimum leaf mass [gCH2O/m2] + StemMassMin => noahmp%biochem%state%StemMassMin ,& ! out, minimum stem mass [gCH2O/m2] + StemAreaPerMass => noahmp%biochem%state%StemAreaPerMass ,& ! out, stem area per unit mass [m2/g] + RespFacTemperature => noahmp%biochem%state%RespFacTemperature ,& ! out, temperature factor + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [gC/m2] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon [gC/m2] + CarbonAssim => noahmp%biochem%flux%CarbonAssim ,& ! out, carbon assimilated rate [gC/m2/s] + CarbohydrAssim => noahmp%biochem%flux%CarbohydrAssim ,& ! out, carbohydrate assimilated rate [gCH2O/m2/s] + TurnoverLeaf => noahmp%biochem%flux%TurnoverLeaf ,& ! out, leaf turnover rate [gCH2O/m2/s] + TurnoverStem => noahmp%biochem%flux%TurnoverStem ,& ! out, stem turnover rate [gCH2O/m2/s] + TurnoverRoot => noahmp%biochem%flux%TurnoverRoot ,& ! out, root carbon loss rate by turnover [gCH2O/m2/s] + ConvLeafToGrain => noahmp%biochem%flux%ConvLeafToGrain ,& ! out, leaf to grain conversion [gCH2O/m2] + ConvRootToGrain => noahmp%biochem%flux%ConvRootToGrain ,& ! out, root to grain conversion [gCH2O/m2] + ConvStemToGrain => noahmp%biochem%flux%ConvStemToGrain ,& ! out, stem to grain conversion [gCH2O/m2] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [gC/m2/s C] + CarbonToAtmos => noahmp%biochem%flux%CarbonToAtmos ,& ! out, carbon flux to atmosphere [gC/m2/s] + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, gross primary production [gC/m2/s] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, total net primary productivity [gC/m2/s] + NetPriProductionLeaf => noahmp%biochem%flux%NetPriProductionLeaf ,& ! out, leaf net primary productivity [gCH2O/m2/s] + NetPriProductionRoot => noahmp%biochem%flux%NetPriProductionRoot ,& ! out, root net primary productivity [gCH2O/m2/s] + NetPriProductionStem => noahmp%biochem%flux%NetPriProductionStem ,& ! out, stem net primary productivity [gCH2O/m2/s] + NetPriProductionGrain => noahmp%biochem%flux%NetPriProductionGrain ,& ! out, grain net primary productivity [gCH2O/m2/s] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [gCO2/m2/s] + GrowthRespGrain => noahmp%biochem%flux%GrowthRespGrain ,& ! out, growth respiration rate for grain [gCH2O/m2/s] + GrowthRespLeaf => noahmp%biochem%flux%GrowthRespLeaf ,& ! out, growth respiration rate for leaf [gCH2O/m2/s] + GrowthRespRoot => noahmp%biochem%flux%GrowthRespRoot ,& ! out, growth respiration rate for root [gCH2O/m2/s] + GrowthRespStem => noahmp%biochem%flux%GrowthRespStem ,& ! out, growth respiration rate for stem [gCH2O/m2/s] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration rate [gC/m2/s] + LeafMassMaxChg => noahmp%biochem%flux%LeafMassMaxChg ,& ! out, maximum leaf mass available to change [gCH2O/m2/s] + StemMassMaxChg => noahmp%biochem%flux%StemMassMaxChg ,& ! out, maximum steam mass available to change [gCH2O/m2/s] + RespirationLeaf => noahmp%biochem%flux%RespirationLeaf ,& ! out, leaf respiration rate [umol CO2/m2/s] + RespirationStem => noahmp%biochem%flux%RespirationStem ,& ! out, stem respiration rate [gCH2O/m2/s] + RespirationLeafMaint => noahmp%biochem%flux%RespirationLeafMaint ,& ! out, leaf maintenance respiration rate [gCH2O/m2/s] + RespirationRoot => noahmp%biochem%flux%RespirationRoot ,& ! out, fine root respiration rate [gCH2O/m2/s] + RespirationSoil => noahmp%biochem%flux%RespirationSoil ,& ! out, soil respiration rate [gCH2O/m2/s] + RespirationGrain => noahmp%biochem%flux%RespirationGrain ,& ! out, grain respiration rate [gCH2O/m2/s] + DeathLeaf => noahmp%biochem%flux%DeathLeaf ,& ! out, death rate of leaf mass [gCH2O/m2/s] + CarbonDecayToStable => noahmp%biochem%flux%CarbonDecayToStable & ! out, decay rate of fast carbon to slow carbon [gCH2O/m2/s] + ) +!---------------------------------------------------------------------- + + ! initialization + StemAreaPerMass = 3.0 * 0.001 ! m2/kg -->m2/g + LeafMassMin = LeafAreaIndexMin / 0.035 + StemMassMin = StemAreaIndexMin / StemAreaPerMass + + !!! carbon assimilation starts + ! 1 mole -> 12 g carbon or 44 g CO2 or 30 g CH20 + CarbonAssim = PhotosynTotal * 12.0e-6 !*IndexPlanting !umol co2 /m2/ s -> g/m2/s C + CarbohydrAssim = PhotosynTotal * 30.0e-6 !*IndexPlanting !umol co2 /m2/ s -> g/m2/s CH2O + + ! mainteinance respiration + RespFacNitrogenFoliage = min(NitrogenConcFoliage / max(1.0e-06, NitrogenConcFoliageMax), 1.0) + RespFacTemperature = RespMaintQ10**((TemperatureCanopy - 298.16) / 10.0) + RespirationLeaf = RespMaintLeaf25C * RespFacTemperature * RespFacNitrogenFoliage * & + LeafAreaIndex * (1.0 - SoilWaterStress) ! umolCO2/m2/s + RespirationLeafMaint = min((LeafMass - LeafMassMin) / MainTimeStep, RespirationLeaf*30.0e-6) ! gCH2O/m2/s + RespirationRoot = RespMaintRoot25C * (RootMass * 1.0e-3) * RespFacTemperature * 30.0e-6 ! gCH2O/m2/s + RespirationStem = RespMaintStem25C * (StemMass * 1.0e-3) * RespFacTemperature * 30.0e-6 ! gCH2O/m2/s + RespirationGrain = RespMaintGrain25C * (GrainMass * 1.0e-3) * RespFacTemperature * 30.0e-6 ! gCH2O/m2/s + + ! calculate growth respiration for leaf, root and grain + GrowthRespLeaf = max(0.0, GrowthRespFrac * (CarbohydrFracToLeaf(PlantGrowStage)*CarbohydrAssim - RespirationLeafMaint)) ! gCH2O/m2/s + GrowthRespStem = max(0.0, GrowthRespFrac * (CarbohydrFracToStem(PlantGrowStage)*CarbohydrAssim - RespirationStem)) ! gCH2O/m2/s + GrowthRespRoot = max(0.0, GrowthRespFrac * (CarbohydrFracToRoot(PlantGrowStage)*CarbohydrAssim - RespirationRoot)) ! gCH2O/m2/s + GrowthRespGrain = max(0.0, GrowthRespFrac * (CarbohydrFracToGrain(PlantGrowStage)*CarbohydrAssim - RespirationGrain)) ! gCH2O/m2/s + + ! leaf turnover, stem turnover, root turnover and leaf death caused by soil water and soil temperature stress + TurnoverLeaf = TurnoverCoeffLeafCrop(PlantGrowStage) * 1.0e-6 * LeafMass ! gCH2O/m2/s + TurnoverRoot = TurnoverCoeffRootCrop(PlantGrowStage) * 1.0e-6 * RootMass ! gCH2O/m2/s + TurnoverStem = TurnoverCoeffStemCrop(PlantGrowStage) * 1.0e-6 * StemMass ! gCH2O/m2/s + DeathCoeffTemp = exp(-0.3 * max(0.0, TemperatureCanopy-TemperaureLeafFreeze)) * (LeafMass/120.0) + DeathCoeffWater = exp((SoilWaterStress - 1.0) * WaterStressCoeff) + DeathLeaf = LeafMass * 1.0e-6 * (LeafDeathWaterCoeffCrop(PlantGrowStage) * DeathCoeffWater + & + LeafDeathTempCoeffCrop(PlantGrowStage) * DeathCoeffTemp) ! gCH2O/m2/s + + ! Allocation of CarbohydrAssim to leaf, stem, root and grain at each growth stage + !NetPriProdLeafAdd = max(0.0, CarbohydrFracToLeaf(PlantGrowStage)*CarbohydrAssim - GrowthRespLeaf - RespirationLeafMaint) ! gCH2O/m2/s + NetPriProdLeafAdd = CarbohydrFracToLeaf(PlantGrowStage)*CarbohydrAssim - GrowthRespLeaf - RespirationLeafMaint ! gCH2O/m2/s + !NetPriProdStemAdd = max(0.0, CarbohydrFracToStem(PlantGrowStage)*CarbohydrAssim - GrowthRespStem - RespirationStem) ! gCH2O/m2/s + NetPriProdStemAdd = CarbohydrFracToStem(PlantGrowStage)*CarbohydrAssim - GrowthRespStem - RespirationStem ! gCH2O/m2/s + + ! avoid reducing leaf mass below its minimum value but conserve mass + LeafMassMaxChg = (LeafMass - LeafMassMin) / MainTimeStep ! gCH2O/m2/s + StemMassMaxChg = (StemMass - StemMassMin) / MainTimeStep ! gCH2O/m2/s + TurnoverLeaf = min(TurnoverLeaf, LeafMassMaxChg+NetPriProdLeafAdd) ! gCH2O/m2/s + TurnoverStem = min(TurnoverStem, StemMassMaxChg+NetPriProdStemAdd) ! gCH2O/m2/s + DeathLeaf = min(DeathLeaf, LeafMassMaxChg+NetPriProdLeafAdd-TurnoverLeaf) ! gCH2O/m2/s + + ! net primary productivities + !NetPriProductionLeaf = max(NetPriProdLeafAdd, -LeafMassMaxChg) ! gCH2O/m2/s + NetPriProductionLeaf = NetPriProdLeafAdd ! gCH2O/m2/s + !NetPriProductionStem = max(NetPriProdStemAdd, -StemMassMaxChg) ! gCH2O/m2/s + NetPriProductionStem = NetPriProdStemAdd ! gCH2O/m2/s + NetPriProductionRoot = CarbohydrFracToRoot(PlantGrowStage) * CarbohydrAssim - RespirationRoot - GrowthRespRoot ! gCH2O/m2/s + NetPriProductionGrain = CarbohydrFracToGrain(PlantGrowStage) * CarbohydrAssim - RespirationGrain - GrowthRespGrain ! gCH2O/m2/s + + ! masses of plant components + LeafMass = LeafMass + (NetPriProductionLeaf - TurnoverLeaf - DeathLeaf) * MainTimeStep ! gCH2O/m2 + StemMass = StemMass + (NetPriProductionStem - TurnoverStem) * MainTimeStep ! gCH2O/m2 + RootMass = RootMass + (NetPriProductionRoot - TurnoverRoot) * MainTimeStep ! gCH2O/m2 + GrainMass = GrainMass + NetPriProductionGrain * MainTimeStep ! gCH2O/m2 + GrossPriProduction = CarbohydrAssim * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + + ! carbon convert to grain ! Zhe Zhang 2020-07-13 + ConvLeafToGrain = 0.0 + ConvStemToGrain = 0.0 + ConvRootToGrain = 0.0 + ConvLeafToGrain = LeafMass * (CarbohydrLeafToGrain(PlantGrowStage) * MainTimeStep / 3600.0) ! gCH2O/m2 + ConvStemToGrain = StemMass * (CarbohydrStemToGrain(PlantGrowStage) * MainTimeStep / 3600.0) ! gCH2O/m2 + ConvRootToGrain = RootMass * (CarbohydrRootToGrain(PlantGrowStage) * MainTimeStep / 3600.0) ! gCH2O/m2 + LeafMass = LeafMass - ConvLeafToGrain ! gCH2O/m2 + StemMass = StemMass - ConvStemToGrain ! gCH2O/m2 + RootMass = RootMass - ConvRootToGrain ! gCH2O/m2 + GrainMass = GrainMass + ConvStemToGrain + ConvRootToGrain + ConvLeafToGrain ! gCH2O/m2 + !if ( PlantGrowStage==6 ) then + ! ConvStemToGrain = StemMass * (0.00005 * MainTimeStep / 3600.0) ! gCH2O/m2 + ! StemMass = StemMass - ConvStemToGrain ! gCH2O/m2 + ! ConvRootToGrain = RootMass * (0.0005 * MainTimeStep / 3600.0) ! gCH2O/m2 + ! RootMass = RootMass - ConvRootToGrain ! gCH2O/m2 + ! GrainMass = GrainMass + ConvStemToGrain + ConvRootToGrain ! gCH2O/m2 + !endif + + if ( RootMass < 0.0 ) then + TurnoverRoot = NetPriProductionRoot + RootMass = 0.0 + endif + if ( GrainMass < 0.0 ) then + GrainMass = 0.0 + endif + + ! soil carbon budgets + !if ( (PlantGrowStage == 1) .or. (PlantGrowStage == 2) .or. (PlantGrowStage == 8) ) then + ! CarbonMassShallowSoil = 1000 + !else + CarbonMassShallowSoil = CarbonMassShallowSoil + & + (TurnoverRoot+TurnoverLeaf+TurnoverStem+DeathLeaf) * MainTimeStep * 0.4 ! 0.4: gCH2O/m2 -> gC/m2 + !endif + MicroRespFactorSoilTemp = 2.0**((TemperatureSoilSnow(1) - 283.16) / 10.0) + MicroRespFactorSoilWater = SoilWaterRootZone / (0.20 + SoilWaterRootZone) * 0.23 / (0.23 + SoilWaterRootZone) + RespirationSoil = MicroRespFactorSoilWater * MicroRespFactorSoilTemp * & + MicroRespCoeff * max(0.0, CarbonMassShallowSoil*1.0e-3) * 30.0e-6 ! gCH2O/m2/s + CarbonDecayToStable = 0.1 * RespirationSoil ! gCH2O/m2/s + CarbonMassShallowSoil = CarbonMassShallowSoil - (RespirationSoil + CarbonDecayToStable) * MainTimeStep * 0.4 ! 0.4: gCH2O/m2 -> gC/m2 + CarbonMassDeepSoil = CarbonMassDeepSoil + CarbonDecayToStable * MainTimeStep * 0.4 ! 0.4: gCH2O/m2 -> gC/m2 + + ! total carbon flux + CarbonToAtmos = - CarbonAssim + (RespirationLeafMaint + RespirationRoot + RespirationStem + RespirationGrain + & + 0.9*RespirationSoil + GrowthRespLeaf + GrowthRespRoot + GrowthRespStem + GrowthRespGrain) * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + + ! for outputs + NetPriProductionTot = (NetPriProductionLeaf + NetPriProductionStem + & + NetPriProductionRoot + NetPriProductionGrain) * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + RespirationPlantTot = (RespirationRoot + RespirationGrain + RespirationLeafMaint + RespirationStem + & + GrowthRespLeaf + GrowthRespRoot + GrowthRespGrain + GrowthRespStem) * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + RespirationSoilOrg = 0.9 * RespirationSoil * 0.4 ! gC/m2/s 0.4=12/30, CH20 to C + NetEcoExchange = (RespirationPlantTot + RespirationSoilOrg - GrossPriProduction) * 44.0 / 12.0 ! gCO2/m2/s + CarbonMassSoilTot = CarbonMassShallowSoil + CarbonMassDeepSoil ! gC/m2 + CarbonMassLiveTot = (LeafMass + RootMass + StemMass + GrainMass) * 0.4 ! gC/m2 0.4=12/30, CH20 to C + + ! leaf area index and stem area index + LeafAreaIndex = max(LeafMass*LeafAreaPerBiomass, LeafAreaIndexMin) + StemAreaIndex = max(StemMass*StemAreaPerMass, StemAreaIndexMin) + + ! After harversting + !if ( PlantGrowStage == 8 ) then + ! LeafMass = 0.62 + ! StemMass = 0.0 + ! GrainMass = 0.0 + !endif + + !if ( (PlantGrowStage == 1) .or. (PlantGrowStage == 2) .or. (PlantGrowStage == 8) ) then + if ( (PlantGrowStage == 8) .and. & + ((GrainMass > 0) .or. (LeafMass > 0) .or. (StemMass > 0) .or. (RootMass > 0)) ) then + LeafAreaIndex = 0.05 + StemAreaIndex = 0.05 + LeafMass = LeafMassMin + StemMass = StemMassMin + RootMass = 0.0 + GrainMass = 0.0 + endif + + end associate + + end subroutine CarbonFluxCrop + +end module CarbonFluxCropMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxNatureVegMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxNatureVegMod.F90 new file mode 100644 index 0000000000..38dc8b0793 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CarbonFluxNatureVegMod.F90 @@ -0,0 +1,248 @@ +module CarbonFluxNatureVegMod + +!!! Main Carbon assimilation for natural/generic vegetation +!!! based on RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CarbonFluxNatureVeg(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CO2FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: DeathCoeffTemp ! temperature stress death coefficient + real(kind=kind_noahmp) :: DeathCoeffWater ! water stress death coefficient + real(kind=kind_noahmp) :: NetPriProdLeafAdd ! leaf assimil after resp. losses removed [gC/m2/s] + real(kind=kind_noahmp) :: NetPriProdStemAdd ! stem assimil after resp. losses removed [gC/m2/s] + real(kind=kind_noahmp) :: RespTmp, Temp0 ! temperary vars for function below + RespTmp(Temp0) = exp(0.08 * (Temp0 - 298.16)) ! Respiration as a function of temperature + +!------------------------------------------------------------------------ + associate( & + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + IndexEBLForest => noahmp%config%domain%IndexEBLForest ,& ! in, flag for Evergreen Broadleaf Forest + WoodToRootRatio => noahmp%biochem%param%WoodToRootRatio ,& ! in, wood to root ratio + TurnoverCoeffLeafVeg => noahmp%biochem%param%TurnoverCoeffLeafVeg ,& ! in, leaf turnover coefficient [1/s] for generic vegetation + TemperaureLeafFreeze => noahmp%biochem%param%TemperaureLeafFreeze ,& ! in, characteristic temperature for leaf freezing [K] + LeafDeathWaterCoeffVeg => noahmp%biochem%param%LeafDeathWaterCoeffVeg ,& ! in, coeficient for leaf water stress death [1/s] for generic veg + LeafDeathTempCoeffVeg => noahmp%biochem%param%LeafDeathTempCoeffVeg ,& ! in, coeficient for leaf temp. stress death [1/s] for generic veg + GrowthRespFrac => noahmp%biochem%param%GrowthRespFrac ,& ! in, fraction of growth respiration + TemperatureMinPhotosyn => noahmp%biochem%param%TemperatureMinPhotosyn ,& ! in, minimum temperature for photosynthesis [K] + MicroRespCoeff => noahmp%biochem%param%MicroRespCoeff ,& ! in, microbial respiration parameter [umol CO2/kgC/s] + NitrogenConcFoliageMax => noahmp%biochem%param%NitrogenConcFoliageMax ,& ! in, foliage nitrogen concentration when f(n)=1 (%) + RespMaintQ10 => noahmp%biochem%param%RespMaintQ10 ,& ! in, q10 for maintenance respiration + RespMaintLeaf25C => noahmp%biochem%param%RespMaintLeaf25C ,& ! in, leaf maintenance respiration at 25c [umol CO2/m2/s] + RespMaintRoot25C => noahmp%biochem%param%RespMaintRoot25C ,& ! in, root maintenance respiration at 25c [umol CO2/kgC/s] + RespMaintStem25C => noahmp%biochem%param%RespMaintStem25C ,& ! in, stem maintenance respiration at 25c [umol CO2/kgC/s] + WoodPoolIndex => noahmp%biochem%param%WoodPoolIndex ,& ! in, wood pool index (0~1) depending on woody or not + TurnoverCoeffRootVeg => noahmp%biochem%param%TurnoverCoeffRootVeg ,& ! in, root turnover coefficient [1/s] for generic vegetation + WoodRespCoeff => noahmp%biochem%param%WoodRespCoeff ,& ! in, wood respiration coeficient [1/s] + WoodAllocFac => noahmp%biochem%param%WoodAllocFac ,& ! in, parameter for present wood allocation + WaterStressCoeff => noahmp%biochem%param%WaterStressCoeff ,& ! in, water stress coeficient + LeafAreaIndexMin => noahmp%biochem%param%LeafAreaIndexMin ,& ! in, minimum leaf area index [m2/m2] + StemAreaIndexMin => noahmp%biochem%param%StemAreaIndexMin ,& ! in, minimum stem area index [m2/m2] + IndexGrowSeason => noahmp%biochem%state%IndexGrowSeason ,& ! in, growing season index (0=off, 1=on) + NitrogenConcFoliage => noahmp%biochem%state%NitrogenConcFoliage ,& ! in, foliage nitrogen concentration [%] + LeafAreaPerMass => noahmp%biochem%state%LeafAreaPerMass ,& ! in, leaf area per unit mass [m2/g] + PhotosynTotal => noahmp%biochem%flux%PhotosynTotal ,& ! in, total leaf photosynthesis [umolCO2/m2/s] + SoilWaterRootZone => noahmp%water%state%SoilWaterRootZone ,& ! in, root zone soil water + SoilWaterStress => noahmp%water%state%SoilWaterStress ,& ! in, water stress coeficient (1.0 for wilting) + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, leaf area index + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, stem area index + LeafMass => noahmp%biochem%state%LeafMass ,& ! inout, leaf mass [gC/m2] + RootMass => noahmp%biochem%state%RootMass ,& ! inout, mass of fine roots [gC/m2] + StemMass => noahmp%biochem%state%StemMass ,& ! inout, stem mass [gC/m2] + WoodMass => noahmp%biochem%state%WoodMass ,& ! inout, mass of wood (incl. woody roots) [gC/m2] + CarbonMassDeepSoil => noahmp%biochem%state%CarbonMassDeepSoil ,& ! inout, stable carbon in deep soil [gC/m2] + CarbonMassShallowSoil => noahmp%biochem%state%CarbonMassShallowSoil ,& ! inout, short-lived carbon in shallow soil [gC/m2] + CarbonMassSoilTot => noahmp%biochem%state%CarbonMassSoilTot ,& ! out, total soil carbon [gC/m2] + CarbonMassLiveTot => noahmp%biochem%state%CarbonMassLiveTot ,& ! out, total living carbon ([gC/m2] + LeafMassMin => noahmp%biochem%state%LeafMassMin ,& ! out, minimum leaf mass [gC/m2] + CarbonFracToLeaf => noahmp%biochem%state%CarbonFracToLeaf ,& ! out, fraction of carbon allocated to leaves + WoodCarbonFrac => noahmp%biochem%state%WoodCarbonFrac ,& ! out, calculated wood to root ratio + CarbonFracToWoodRoot => noahmp%biochem%state%CarbonFracToWoodRoot ,& ! out, fraction of carbon to root and wood + CarbonFracToRoot => noahmp%biochem%state%CarbonFracToRoot ,& ! out, fraction of carbon flux to roots + CarbonFracToWood => noahmp%biochem%state%CarbonFracToWood ,& ! out, fraction of carbon flux to wood + CarbonFracToStem => noahmp%biochem%state%CarbonFracToStem ,& ! out, fraction of carbon flux to stem + MicroRespFactorSoilWater => noahmp%biochem%state%MicroRespFactorSoilWater ,& ! out, soil water factor for microbial respiration + MicroRespFactorSoilTemp => noahmp%biochem%state%MicroRespFactorSoilTemp ,& ! out, soil temperature factor for microbial respiration + RespFacNitrogenFoliage => noahmp%biochem%state%RespFacNitrogenFoliage ,& ! out, foliage nitrogen adjustemt to respiration (<= 1) + RespFacTemperature => noahmp%biochem%state%RespFacTemperature ,& ! out, temperature factor + RespReductionFac => noahmp%biochem%state%RespReductionFac ,& ! out, respiration reduction factor (<= 1) + StemMassMin => noahmp%biochem%state%StemMassMin ,& ! out, minimum stem mass [gC/m2] + StemAreaPerMass => noahmp%biochem%state%StemAreaPerMass ,& ! out, stem area per unit mass [m2/g] + CarbonAssim => noahmp%biochem%flux%CarbonAssim ,& ! out, carbon assimilated rate [gC/m2/s] + GrossPriProduction => noahmp%biochem%flux%GrossPriProduction ,& ! out, gross primary production [gC/m2/s] + NetPriProductionTot => noahmp%biochem%flux%NetPriProductionTot ,& ! out, total net primary productivity [gC/m2/s] + NetEcoExchange => noahmp%biochem%flux%NetEcoExchange ,& ! out, net ecosystem exchange [gCO2/m2/s] + RespirationPlantTot => noahmp%biochem%flux%RespirationPlantTot ,& ! out, total plant respiration [gC/m2/s] + RespirationSoilOrg => noahmp%biochem%flux%RespirationSoilOrg ,& ! out, soil organic respiration [gC/m2/s] + CarbonToAtmos => noahmp%biochem%flux%CarbonToAtmos ,& ! out, carbon flux to atmosphere [gC/m2/s] + NetPriProductionLeaf => noahmp%biochem%flux%NetPriProductionLeaf ,& ! out, leaf net primary productivity [gC/m2/s] + NetPriProductionRoot => noahmp%biochem%flux%NetPriProductionRoot ,& ! out, root net primary productivity [gC/m2/s] + NetPriProductionWood => noahmp%biochem%flux%NetPriProductionWood ,& ! out, wood net primary productivity [gC/m2/s] + NetPriProductionStem => noahmp%biochem%flux%NetPriProductionStem ,& ! out, stem net primary productivity [gC/m2/s] + GrowthRespLeaf => noahmp%biochem%flux%GrowthRespLeaf ,& ! out, growth respiration rate for leaf [gC/m2/s] + GrowthRespRoot => noahmp%biochem%flux%GrowthRespRoot ,& ! out, growth respiration rate for root [gC/m2/s] + GrowthRespWood => noahmp%biochem%flux%GrowthRespWood ,& ! out, growth respiration rate for wood [gC/m2/s] + GrowthRespStem => noahmp%biochem%flux%GrowthRespStem ,& ! out, growth respiration rate for stem [gC/m2/s] + LeafMassMaxChg => noahmp%biochem%flux%LeafMassMaxChg ,& ! out, maximum leaf mass available to change [gC/m2/s] + CarbonDecayToStable => noahmp%biochem%flux%CarbonDecayToStable ,& ! out, decay rate of fast carbon to slow carbon [gC/m2/s] + RespirationLeaf => noahmp%biochem%flux%RespirationLeaf ,& ! out, leaf respiration rate [umol CO2/m2/s] + RespirationStem => noahmp%biochem%flux%RespirationStem ,& ! out, stem respiration rate [gC/m2/s] + RespirationWood => noahmp%biochem%flux%RespirationWood ,& ! out, wood respiration rate [gC/m2/s] + RespirationLeafMaint => noahmp%biochem%flux%RespirationLeafMaint ,& ! out, leaf maintenance respiration rate [gC/m2/s] + RespirationRoot => noahmp%biochem%flux%RespirationRoot ,& ! out, fine root respiration rate [gC/m2/s] + RespirationSoil => noahmp%biochem%flux%RespirationSoil ,& ! out, soil respiration rate [gC/m2/s] + DeathLeaf => noahmp%biochem%flux%DeathLeaf ,& ! out, death rate of leaf mass [gC/m2/s] + DeathStem => noahmp%biochem%flux%DeathStem ,& ! out, death rate of stem mass [gC/m2/s] + TurnoverLeaf => noahmp%biochem%flux%TurnoverLeaf ,& ! out, leaf turnover rate [gC/m2/s] + TurnoverStem => noahmp%biochem%flux%TurnoverStem ,& ! out, stem turnover rate [gC/m2/s] + TurnoverWood => noahmp%biochem%flux%TurnoverWood ,& ! out, wood turnover rate [gC/m2/s] + TurnoverRoot => noahmp%biochem%flux%TurnoverRoot ,& ! out, root turnover rate [gC/m2/s] + StemMassMaxChg => noahmp%biochem%flux%StemMassMaxChg & ! out, maximum steam mass available to change [gC/m2/s] + ) +!----------------------------------------------------------------------- + + ! initialization + StemAreaPerMass = 3.0 * 0.001 ! m2/kg -->m2/g + LeafMassMin = LeafAreaIndexMin / LeafAreaPerMass ! gC/m2 + StemMassMin = StemAreaIndexMin / StemAreaPerMass ! gC/m2 + + ! respiration + if ( IndexGrowSeason == 0.0 ) then + RespReductionFac = 0.5 + else + RespReductionFac = 1.0 + endif + RespFacNitrogenFoliage = min(NitrogenConcFoliage / max(1.0e-06,NitrogenConcFoliageMax), 1.0) + RespFacTemperature = RespMaintQ10**((TemperatureCanopy - 298.16) / 10.0) + RespirationLeaf = RespMaintLeaf25C * RespFacTemperature * RespFacNitrogenFoliage * & + LeafAreaIndex * RespReductionFac * (1.0 - SoilWaterStress) ! umol CO2/m2/s + RespirationLeafMaint = min((LeafMass-LeafMassMin)/MainTimeStep, RespirationLeaf*12.0e-6) ! gC/m2/s + RespirationRoot = RespMaintRoot25C * (RootMass*1.0e-3) * RespFacTemperature * RespReductionFac * 12.0e-6 ! gC/m2/s + RespirationStem = RespMaintStem25C * ((StemMass-StemMassMin) * 1.0e-3) * & + RespFacTemperature * RespReductionFac * 12.0e-6 ! gC/m2/s + RespirationWood = WoodRespCoeff * RespTmp(TemperatureCanopy) * WoodMass * WoodPoolIndex ! gC/m2/s + + !!! carbon assimilation start + ! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon; + CarbonAssim = PhotosynTotal * 12.0e-6 ! umol CO2/m2/s -> gC/m2/s + + ! fraction of carbon into leaf versus nonleaf + CarbonFracToLeaf = exp(0.01 * (1.0 - exp(0.75*LeafAreaIndex)) * LeafAreaIndex) + if ( VegType == IndexEBLForest ) CarbonFracToLeaf = exp(0.01 * (1.0 - exp(0.50*LeafAreaIndex)) * LeafAreaIndex) + CarbonFracToWoodRoot = 1.0 - CarbonFracToLeaf + CarbonFracToStem = LeafAreaIndex / 10.0 * CarbonFracToLeaf + CarbonFracToLeaf = CarbonFracToLeaf - CarbonFracToStem + + ! fraction of carbon into wood versus root + if ( WoodMass > 1.0e-6 ) then + WoodCarbonFrac = (1.0 - exp(-WoodAllocFac * (WoodToRootRatio*RootMass/WoodMass)) / WoodAllocFac) * WoodPoolIndex + else + WoodCarbonFrac = WoodPoolIndex + endif + CarbonFracToRoot = CarbonFracToWoodRoot * (1.0 - WoodCarbonFrac) + CarbonFracToWood = CarbonFracToWoodRoot * WoodCarbonFrac + + ! leaf and root turnover per time step + TurnoverLeaf = TurnoverCoeffLeafVeg * 5.0e-7 * LeafMass ! gC/m2/s + TurnoverStem = TurnoverCoeffLeafVeg * 5.0e-7 * StemMass ! gC/m2/s + TurnoverRoot = TurnoverCoeffRootVeg * RootMass ! gC/m2/s + TurnoverWood = 9.5e-10 * WoodMass ! gC/m2/s + + ! seasonal leaf die rate dependent on temp and water stress + ! water stress is set to 1 at permanent wilting point + DeathCoeffTemp = exp(-0.3 * max(0.0, TemperatureCanopy-TemperaureLeafFreeze)) * (LeafMass / 120.0) + DeathCoeffWater = exp((SoilWaterStress - 1.0) * WaterStressCoeff) + DeathLeaf = LeafMass * 1.0e-6 * (LeafDeathWaterCoeffVeg * DeathCoeffWater + LeafDeathTempCoeffVeg * DeathCoeffTemp) ! gC/m2/s + DeathStem = StemMass * 1.0e-6 * (LeafDeathWaterCoeffVeg * DeathCoeffWater + LeafDeathTempCoeffVeg * DeathCoeffTemp) ! gC/m2/s + + ! calculate growth respiration for leaf, root and wood + GrowthRespLeaf = max(0.0, GrowthRespFrac * (CarbonFracToLeaf*CarbonAssim - RespirationLeafMaint)) ! gC/m2/s + GrowthRespStem = max(0.0, GrowthRespFrac * (CarbonFracToStem*CarbonAssim - RespirationStem)) ! gC/m2/s + GrowthRespRoot = max(0.0, GrowthRespFrac * (CarbonFracToRoot*CarbonAssim - RespirationRoot)) ! gC/m2/s + GrowthRespWood = max(0.0, GrowthRespFrac * (CarbonFracToWood*CarbonAssim - RespirationWood)) ! gC/m2/s + + ! Impose lower T limit for photosynthesis + NetPriProdLeafAdd = max(0.0, CarbonFracToLeaf*CarbonAssim - GrowthRespLeaf - RespirationLeafMaint) ! gC/m2/s + NetPriProdStemAdd = max(0.0, CarbonFracToStem*CarbonAssim - GrowthRespStem - RespirationStem) ! gC/m2/s + !NetPriProdLeafAdd = CarbonFracToLeaf*CarbonAssim - GrowthRespLeaf - RespirationLeafMaint ! MB: test Kjetil + !NetPriProdStemAdd = CarbonFracToStem*CarbonAssim - GrowthRespStem - RespirationStem ! MB: test Kjetil + if ( TemperatureCanopy < TemperatureMinPhotosyn ) NetPriProdLeafAdd = 0.0 + if ( TemperatureCanopy < TemperatureMinPhotosyn ) NetPriProdStemAdd = 0.0 + + ! update leaf, root, and wood carbon + ! avoid reducing leaf mass below its minimum value but conserve mass + LeafMassMaxChg = (LeafMass - LeafMassMin) / MainTimeStep ! gC/m2/s + StemMassMaxChg = (StemMass - StemMassMin) / MainTimeStep ! gC/m2/s + DeathLeaf = min(DeathLeaf, LeafMassMaxChg+NetPriProdLeafAdd-TurnoverLeaf) ! gC/m2/s + DeathStem = min(DeathStem, StemMassMaxChg+NetPriProdStemAdd-TurnoverStem) ! gC/m2/s + + ! net primary productivities + NetPriProductionLeaf = max(NetPriProdLeafAdd, -LeafMassMaxChg) ! gC/m2/s + NetPriProductionStem = max(NetPriProdStemAdd, -StemMassMaxChg) ! gC/m2/s + NetPriProductionRoot = CarbonFracToRoot * CarbonAssim - RespirationRoot - GrowthRespRoot ! gC/m2/s + NetPriProductionWood = CarbonFracToWood * CarbonAssim - RespirationWood - GrowthRespWood ! gC/m2/s + + ! masses of plant components + LeafMass = LeafMass + (NetPriProductionLeaf - TurnoverLeaf - DeathLeaf) * MainTimeStep ! gC/m2 + StemMass = StemMass + (NetPriProductionStem - TurnoverStem - DeathStem) * MainTimeStep ! gC/m2 + RootMass = RootMass + (NetPriProductionRoot - TurnoverRoot) * MainTimeStep ! gC/m2 + if ( RootMass < 0.0 ) then + TurnoverRoot = NetPriProductionRoot + RootMass = 0.0 + endif + WoodMass = (WoodMass + (NetPriProductionWood - TurnoverWood) * MainTimeStep ) * WoodPoolIndex ! gC/m2 + + ! soil carbon budgets + CarbonMassShallowSoil = CarbonMassShallowSoil + & + (TurnoverRoot+TurnoverLeaf+TurnoverStem+TurnoverWood+DeathLeaf+DeathStem) * MainTimeStep ! gC/m2, MB: add DeathStem v3.7 + MicroRespFactorSoilTemp = 2.0**( (TemperatureSoilSnow(1) - 283.16) / 10.0 ) + MicroRespFactorSoilWater = SoilWaterRootZone / (0.20 + SoilWaterRootZone) * 0.23 / (0.23 + SoilWaterRootZone) + RespirationSoil = MicroRespFactorSoilWater * MicroRespFactorSoilTemp * & + MicroRespCoeff * max(0.0, CarbonMassShallowSoil*1.0e-3) * 12.0e-6 ! gC/m2/s + CarbonDecayToStable = 0.1 * RespirationSoil ! gC/m2/s + CarbonMassShallowSoil = CarbonMassShallowSoil - (RespirationSoil + CarbonDecayToStable) * MainTimeStep ! gC/m2 + CarbonMassDeepSoil = CarbonMassDeepSoil + CarbonDecayToStable * MainTimeStep ! gC/m2 + + ! total carbon flux ! MB: add RespirationStem,GrowthRespStem,0.9*RespirationSoil v3.7 + CarbonToAtmos = - CarbonAssim + RespirationLeafMaint + RespirationRoot + RespirationWood + RespirationStem + & + 0.9*RespirationSoil + GrowthRespLeaf + GrowthRespRoot + GrowthRespWood + GrowthRespStem ! gC/m2/s + + ! for outputs ! MB: add RespirationStem, GrowthRespStem in RespirationPlantTot v3.7 + GrossPriProduction = CarbonAssim ! gC/m2/s + NetPriProductionTot = NetPriProductionLeaf + NetPriProductionWood + NetPriProductionRoot + NetPriProductionStem ! gC/m2/s + RespirationPlantTot = RespirationRoot + RespirationWood + RespirationLeafMaint + RespirationStem + & + GrowthRespLeaf + GrowthRespRoot + GrowthRespWood + GrowthRespStem ! gC/m2/s + RespirationSoilOrg = 0.9 * RespirationSoil ! gC/m2/s MB: add 0.9* v3.7 + NetEcoExchange = (RespirationPlantTot + RespirationSoilOrg - GrossPriProduction) * 44.0 / 12.0 ! gCO2/m2/s + CarbonMassSoilTot = CarbonMassShallowSoil + CarbonMassDeepSoil ! gC/m2 + CarbonMassLiveTot = LeafMass + RootMass + StemMass + WoodMass ! gC/m2 MB: add StemMass v3.7 + + ! leaf area index and stem area index + LeafAreaIndex = max(LeafMass*LeafAreaPerMass, LeafAreaIndexMin) + StemAreaIndex = max(StemMass*StemAreaPerMass, StemAreaIndexMin) + + end associate + + end subroutine CarbonFluxNatureVeg + +end module CarbonFluxNatureVegMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarInitMod.F90 new file mode 100644 index 0000000000..5c8af537b0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarInitMod.F90 @@ -0,0 +1,89 @@ +module ConfigVarInitMod + +!!! Initialize column (1-D) Noah-MP configuration variables +!!! Configuration variables should be first defined in ConfigVarType.F90 + +! ------------------------ Code history ------------------------------------ +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! -------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine ConfigVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + ! config namelist variable + noahmp%config%nmlist%OptDynamicVeg = undefined_int + noahmp%config%nmlist%OptRainSnowPartition = undefined_int + noahmp%config%nmlist%OptSoilWaterTranspiration = undefined_int + noahmp%config%nmlist%OptGroundResistanceEvap = undefined_int + noahmp%config%nmlist%OptSurfaceDrag = undefined_int + noahmp%config%nmlist%OptStomataResistance = undefined_int + noahmp%config%nmlist%OptSnowAlbedo = undefined_int + noahmp%config%nmlist%OptCanopyRadiationTransfer = undefined_int + noahmp%config%nmlist%OptSnowSoilTempTime = undefined_int + noahmp%config%nmlist%OptSnowThermConduct = undefined_int + noahmp%config%nmlist%OptSoilTemperatureBottom = undefined_int + noahmp%config%nmlist%OptSoilSupercoolWater = undefined_int + noahmp%config%nmlist%OptRunoffSurface = undefined_int + noahmp%config%nmlist%OptRunoffSubsurface = undefined_int + noahmp%config%nmlist%OptSoilPermeabilityFrozen = undefined_int + noahmp%config%nmlist%OptDynVicInfiltration = undefined_int + noahmp%config%nmlist%OptTileDrainage = undefined_int + noahmp%config%nmlist%OptIrrigation = undefined_int + noahmp%config%nmlist%OptIrrigationMethod = undefined_int + noahmp%config%nmlist%OptCropModel = undefined_int + noahmp%config%nmlist%OptSoilProperty = undefined_int + noahmp%config%nmlist%OptPedotransfer = undefined_int + noahmp%config%nmlist%OptGlacierTreatment = undefined_int + + ! config domain variable + noahmp%config%domain%LandUseDataName = "MODIFIED_IGBP_MODIS_NOAH" + noahmp%config%domain%FlagUrban = .false. + noahmp%config%domain%FlagCropland = .false. + noahmp%config%domain%FlagDynamicCrop = .false. + noahmp%config%domain%FlagDynamicVeg = .false. + noahmp%config%domain%FlagSoilProcess = .false. + noahmp%config%domain%NumSoilTimeStep = undefined_int + noahmp%config%domain%NumSnowLayerMax = undefined_int + noahmp%config%domain%NumSnowLayerNeg = undefined_int + noahmp%config%domain%NumSoilLayer = undefined_int + noahmp%config%domain%GridIndexI = undefined_int + noahmp%config%domain%GridIndexJ = undefined_int + noahmp%config%domain%VegType = undefined_int + noahmp%config%domain%CropType = undefined_int + noahmp%config%domain%SurfaceType = undefined_int + noahmp%config%domain%NumSwRadBand = undefined_int + noahmp%config%domain%SoilColor = undefined_int + noahmp%config%domain%IndicatorIceSfc = undefined_int + noahmp%config%domain%NumCropGrowStage = undefined_int + noahmp%config%domain%IndexWaterPoint = undefined_int + noahmp%config%domain%IndexBarrenPoint = undefined_int + noahmp%config%domain%IndexIcePoint = undefined_int + noahmp%config%domain%IndexCropPoint = undefined_int + noahmp%config%domain%IndexEBLForest = undefined_int + noahmp%config%domain%NumDayInYear = undefined_int + noahmp%config%domain%RunoffSlopeType = undefined_int + noahmp%config%domain%MainTimeStep = undefined_real + noahmp%config%domain%SoilTimeStep = undefined_real + noahmp%config%domain%GridSize = undefined_real + noahmp%config%domain%DayJulianInYear = undefined_real + noahmp%config%domain%CosSolarZenithAngle = undefined_real + noahmp%config%domain%RefHeightAboveSfc = undefined_real + noahmp%config%domain%ThicknessAtmosBotLayer = undefined_real + noahmp%config%domain%Latitude = undefined_real + noahmp%config%domain%DepthSoilTempBottom = undefined_real + + end subroutine ConfigVarInitDefault + +end module ConfigVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarType.F90 new file mode 100644 index 0000000000..dc7979f3cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ConfigVarType.F90 @@ -0,0 +1,183 @@ +module ConfigVarType + +!!! Define column (1-D) Noah-MP configuration variables +!!! Configuration variable initialization is done in ConfigVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "namelist" sub-type of config (config%nmlist%variable) + type :: namelist_type + + integer :: OptDynamicVeg ! options for dynamic vegetation + ! 1 -> off (use table LeafAreaIndex; use VegFrac = VegFracGreen from input) + ! 2 -> on (together with OptStomataResistance = 1) + ! 3 -> off (use table LeafAreaIndex; calculate VegFrac) + ! 4 -> off (use table LeafAreaIndex; use maximum vegetation fraction) (default) + ! 5 -> on (use maximum vegetation fraction) + ! 6 -> on (use VegFrac = VegFracGreen from input) + ! 7 -> off (use input LeafAreaIndex; use VegFrac = VegFracGreen from input) + ! 8 -> off (use input LeafAreaIndex; calculate VegFrac) + ! 9 -> off (use input LeafAreaIndex; use maximum vegetation fraction) + integer :: OptRainSnowPartition ! options for partitioning precipitation into rainfall & snowfall + ! 1 -> Jordan (1991) scheme (default) + ! 2 -> BATS: when TemperatureAirRefHeight < freezing point+2.2 + ! 3 -> TemperatureAirRefHeight < freezing point + ! 4 -> Use WRF microphysics output + ! 5 -> Use wetbulb temperature (Wang et al., 2019) + integer :: OptSoilWaterTranspiration ! options for soil moisture factor for stomatal resistance & evapotranspiration + ! 1 -> Noah (soil moisture) (default) + ! 2 -> CLM (matric potential) + ! 3 -> SSiB (matric potential) + integer :: OptGroundResistanceEvap ! options for ground resistent to evaporation/sublimation + ! 1 -> Sakaguchi and Zeng, 2009 (default) + ! 2 -> Sellers (1992) + ! 3 -> adjusted Sellers to decrease ResistanceGrdEvap for wet soil + ! 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in table) + integer :: OptSurfaceDrag ! options for surface layer drag/exchange coefficient + ! 1 -> Monin-Obukhov (M-O) Similarity Theory (MOST) (default) + ! 2 -> original Noah (Chen et al. 1997) + integer :: OptStomataResistance ! options for canopy stomatal resistance + ! 1 -> Ball-Berry scheme (default) + ! 2 -> Jarvis scheme + integer :: OptSnowAlbedo ! options for ground snow surface albedo + ! 1 -> BATS snow albedo scheme (default) + ! 2 -> CLASS snow albedo scheme + integer :: OptCanopyRadiationTransfer ! options for canopy radiation transfer + ! 1 -> modified two-stream (gap=F(solar angle,3D structure, etc)<1-VegFrac) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! 3 -> two-stream applied to vegetated fraction (gap=1-VegFrac) (default) + integer :: OptSnowSoilTempTime ! options for snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; flux top boundary condition (default) + ! 2 -> full implicit (original Noah); temperature top boundary condition + ! 3 -> same as 1, but snow cover for skin temperature calculation (generally improves snow) + integer :: OptSnowThermConduct ! options for snow thermal conductivity + ! 1 -> Stieglitz(yen,1965) scheme (default) + ! 2 -> Anderson, 1976 scheme + ! 3 -> constant + ! 4 -> Verseghy (1991) scheme + ! 5 -> Douvill(Yen, 1981) scheme + integer :: OptSoilTemperatureBottom ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (DepthSoilTempBottom & TemperatureSoilBottom not used) + ! 2 -> TemperatureSoilBottom at DepthSoilTempBottom (8m) read from a file (original Noah) (default) + integer :: OptSoilSupercoolWater ! options for soil supercooled liquid water + ! 1 -> no iteration (Niu and Yang, 2006 JHM) (default) + ! 2 -> Koren's iteration (Koren et al., 1999 JGR) + integer :: OptRunoffSurface ! options for surface runoff + ! 1 -> TOPMODEL with groundwater + ! 2 -> TOPMODEL with an equilibrium water table + ! 3 -> original surface and subsurface runoff (free drainage) (default) + ! 4 -> BATS surface and subsurface runoff (free drainage) + ! 5 -> Miguez-Macho&Fan groundwater scheme + ! 6 -> Variable Infiltration Capacity Model surface runoff scheme + ! 7 -> Xinanjiang Infiltration and surface runoff scheme + ! 8 -> Dynamic VIC surface runoff scheme + integer :: OptRunoffSubsurface ! options for drainage & subsurface runoff + ! 1~8: similar to runoff option, separated from original NoahMP runoff option + ! currently tested & recommended the same option# as surface runoff (default) + integer :: OptSoilPermeabilityFrozen ! options for frozen soil permeability + ! 1 -> linear effects, more permeable (default) + ! 2 -> nonlinear effects, less permeable + integer :: OptDynVicInfiltration ! options for infiltration in dynamic VIC runoff scheme + ! 1 -> Philip scheme (default) + ! 2 -> Green-Ampt scheme + ! 3 -> Smith-Parlange scheme + integer :: OptTileDrainage ! options for tile drainage + ! currently only tested & calibrated to work with runoff option=3 + ! 0 -> No tile drainage (default) + ! 1 -> on (simple scheme) + ! 2 -> on (Hooghoudt's scheme) + integer :: OptIrrigation ! options for irrigation + ! 0 -> No irrigation (default) + ! 1 -> Irrigation ON + ! 2 -> irrigation trigger based on crop season Planting and harvesting dates + ! 3 -> irrigation trigger based on LeafAreaIndex threshold + integer :: OptIrrigationMethod ! options for irrigation method + ! only works when OptIrrigation > 0 + ! 0 -> method based on geo_em fractions (default) + ! 1 -> sprinkler method + ! 2 -> micro/drip irrigation + ! 3 -> surface flooding + integer :: OptCropModel ! options for crop model + ! 0 -> No crop model (default) + ! 1 -> Liu, et al. 2016 crop scheme + integer :: OptSoilProperty ! options for defining soil properties + ! 1 -> use input dominant soil texture (default) + ! 2 -> use input soil texture that varies with depth + ! 3 -> use soil composition (sand, clay, orgm) and pedotransfer function + ! 4 -> use input soil properties + integer :: OptPedotransfer ! options for pedotransfer functions + ! only works when OptSoilProperty = 3 + ! 1 -> Saxton and Rawls (2006) scheme (default) + integer :: OptGlacierTreatment ! options for glacier treatment + ! 1 -> include phase change of ice (default) + ! 2 -> ice treatment more like original Noah + + end type namelist_type + + +!=== define "domain" sub-type of config (config%domain%variable) + type :: domain_type + + character(len=256) :: LandUseDataName ! landuse dataset name (USGS or MODIFIED_IGBP_MODIS_NOAH) + logical :: FlagUrban ! flag for urban grid + logical :: FlagCropland ! flag to identify croplands + logical :: FlagDynamicCrop ! flag to activate dynamic crop model + logical :: FlagDynamicVeg ! flag to activate dynamic vegetation scheme + logical :: FlagSoilProcess ! flag to determine if calculating soil processes + integer :: GridIndexI ! model grid index in x-direction + integer :: GridIndexJ ! model grid index in y-direction + integer :: VegType ! vegetation type + integer :: CropType ! crop type + integer :: NumSoilLayer ! number of soil layers + integer :: NumSnowLayerMax ! maximum number of snow layers + integer :: NumSnowLayerNeg ! actual number of snow layers (negative) + integer :: SurfaceType ! surface type (1=soil; 2=lake) + integer :: NumSwRadBand ! number of shortwave radiation bands + integer :: SoilColor ! soil color type for albedo + integer :: IndicatorIceSfc ! indicator for ice surface/point (1=sea ice, 0=non-ice, -1=land ice) + integer :: IndexWaterPoint ! land type index for water point + integer :: IndexBarrenPoint ! land type index for barren land point + integer :: IndexIcePoint ! land type index for ice point + integer :: IndexCropPoint ! land type index for cropland point + integer :: IndexEBLForest ! land type index for evergreen broadleaf (EBL) Forest + integer :: NumCropGrowStage ! number of crop growth stages + integer :: NumDayInYear ! Number of days in the particular year + integer :: RunoffSlopeType ! underground runoff slope term type + integer :: NumSoilTimeStep ! number of timesteps to calculate soil processes + real(kind=kind_noahmp) :: MainTimeStep ! noahmp main timestep [sec] + real(kind=kind_noahmp) :: SoilTimeStep ! soil timestep [sec] + real(kind=kind_noahmp) :: GridSize ! noahmp model grid spacing [m] + real(kind=kind_noahmp) :: DayJulianInYear ! julian day of the year + real(kind=kind_noahmp) :: CosSolarZenithAngle ! cosine solar zenith angle + real(kind=kind_noahmp) :: RefHeightAboveSfc ! reference height [m] above surface zero plane (including vegetation) + real(kind=kind_noahmp) :: ThicknessAtmosBotLayer ! thickness of atmospheric bottom layers [m] + real(kind=kind_noahmp) :: Latitude ! latitude [degree] + real(kind=kind_noahmp) :: DepthSoilTempBottom ! depth [m, negative] from soil surface for lower boundary soil temperature forcing + + integer , allocatable, dimension(:) :: SoilType ! soil type for each soil layer + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSoilLayer ! depth [m] of layer-bottom from soil surface + real(kind=kind_noahmp), allocatable, dimension(:) :: ThicknessSnowSoilLayer ! snow and soil layer thickness [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilLayer ! snow and soil layer-bottom depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThicknessSoilLayer ! soil layer thickness [m] + + end type domain_type + + +!=== define config type that includes namelist & domain subtypes + type, public :: config_type + + type(namelist_type) :: nmlist + type(domain_type) :: domain + + end type config_type + +end module ConfigVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ConstantDefineMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ConstantDefineMod.F90 new file mode 100644 index 0000000000..4fa3e98745 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ConstantDefineMod.F90 @@ -0,0 +1,40 @@ +module ConstantDefineMod + +!!! Define Noah-MP constant variable values + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + + ! define specific physical constants + real(kind=kind_noahmp), public, parameter :: ConstGravityAcc = 9.80616 ! acceleration due to gravity [m/s2] + real(kind=kind_noahmp), public, parameter :: ConstStefanBoltzmann = 5.67e-08 ! Stefan-Boltzmann constant [W/m2/K4] + real(kind=kind_noahmp), public, parameter :: ConstVonKarman = 0.40 ! von Karman constant + real(kind=kind_noahmp), public, parameter :: ConstFreezePoint = 273.16 ! freezing/melting temperature point [K] + real(kind=kind_noahmp), public, parameter :: ConstLatHeatSublim = 2.8440e06 ! latent heat of sublimation [J/kg] + real(kind=kind_noahmp), public, parameter :: ConstLatHeatEvap = 2.5104e06 ! latent heat of vaporization [J/kg] + real(kind=kind_noahmp), public, parameter :: ConstLatHeatFusion = 0.3336e06 ! latent heat of fusion of water [J/kg] + real(kind=kind_noahmp), public, parameter :: ConstHeatCapacWater = 4.188e06 ! specific heat capacity of water [J/m3/K] + real(kind=kind_noahmp), public, parameter :: ConstHeatCapacIce = 2.094e06 ! specific heat capacity of ice [J/m3/K] + real(kind=kind_noahmp), public, parameter :: ConstHeatCapacAir = 1004.64 ! specific heat capacity of dry air [J/kg/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductWater = 0.57 ! thermal conductivity of water [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductIce = 2.2 ! thermal conductivity of ice [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductAir = 0.023 ! thermal conductivity of air [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductQuartz = 7.7 ! thermal conductivity for quartz [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstThermConductSoilOth = 2.0 ! thermal conductivity for other soil components [W/m/K] + real(kind=kind_noahmp), public, parameter :: ConstGasDryAir = 287.04 ! gas constant for dry air [J/kg/K] + real(kind=kind_noahmp), public, parameter :: ConstGasWaterVapor = 461.269 ! gas constant for water vapor [J/kg/K] + real(kind=kind_noahmp), public, parameter :: ConstDensityWater = 1000.0 ! density of water [kg/m3] + real(kind=kind_noahmp), public, parameter :: ConstDensityIce = 917.0 ! density of ice [kg/m3] + real(kind=kind_noahmp), public, parameter :: ConstPI = 3.14159265 ! pi value + real(kind=kind_noahmp), public, parameter :: ConstDensityGraupel = 500.0 ! graupel bulk density [kg/m3] + real(kind=kind_noahmp), public, parameter :: ConstDensityHail = 917.0 ! hail bulk density [kg/m3] + +end module ConstantDefineMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CropGrowDegreeDayMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CropGrowDegreeDayMod.F90 new file mode 100644 index 0000000000..cbad4158ee --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CropGrowDegreeDayMod.F90 @@ -0,0 +1,107 @@ +module CropGrowDegreeDayMod + +!!! Compute crop growing degree days + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CropGrowDegreeDay(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GROWING_GDD +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: GrowDegDayCnt ! gap bewtween GrowDegreeDay and GrowDegreeDay8 + real(kind=kind_noahmp) :: TemperatureDiff ! temperature difference for growing degree days calculation + real(kind=kind_noahmp) :: TemperatureAirC ! air temperature degC + +!------------------------------------------------------------------------ + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + DayJulianInYear => noahmp%config%domain%DayJulianInYear ,& ! in, Julian day of year + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! in, 2-m air temperature [K] + DatePlanting => noahmp%biochem%param%DatePlanting ,& ! in, Planting day (day of year) + DateHarvest => noahmp%biochem%param%DateHarvest ,& ! in, Harvest date (day of year) + TempBaseGrowDegDay => noahmp%biochem%param%TempBaseGrowDegDay ,& ! in, Base temperature for grow degree day accumulation [C] + TempMaxGrowDegDay => noahmp%biochem%param%TempMaxGrowDegDay ,& ! in, Max temperature for grow degree day accumulation [C] + GrowDegDayEmerg => noahmp%biochem%param%GrowDegDayEmerg ,& ! in, grow degree day from seeding to emergence + GrowDegDayInitVeg => noahmp%biochem%param%GrowDegDayInitVeg ,& ! in, grow degree day from seeding to initial vegetative + GrowDegDayPostVeg => noahmp%biochem%param%GrowDegDayPostVeg ,& ! in, grow degree day from seeding to post vegetative + GrowDegDayInitReprod => noahmp%biochem%param%GrowDegDayInitReprod ,& ! in, grow degree day from seeding to intial reproductive + GrowDegDayMature => noahmp%biochem%param%GrowDegDayMature ,& ! in, grow degree day from seeding to physical maturity + GrowDegreeDay => noahmp%biochem%state%GrowDegreeDay ,& ! inout, crop growing degree days + IndexPlanting => noahmp%biochem%state%IndexPlanting ,& ! out, Planting index index (0=off, 1=on) + IndexHarvest => noahmp%biochem%state%IndexHarvest ,& ! out, Havest index (0=on,1=off) + PlantGrowStage => noahmp%biochem%state%PlantGrowStage & ! out, Plant growth stage (1=S1,2=S2,3=S3) + ) +!------------------------------------------------------------------------ + + ! initialize + TemperatureAirC = TemperatureAir2m - 273.15 + + ! Planting and Havest index + IndexPlanting = 1 ! planting on + IndexHarvest = 1 ! harvest off + + ! turn on/off the planting + if ( DayJulianInYear < DatePlanting ) IndexPlanting = 0 ! planting off + + ! turn on/off the harvesting + if ( DayJulianInYear >= DateHarvest ) IndexHarvest = 0 ! harvest on + + ! Calculate the growing degree days + if ( TemperatureAirC < TempBaseGrowDegDay ) then + TemperatureDiff = 0.0 + elseif ( TemperatureAirC >= TempMaxGrowDegDay ) then + TemperatureDiff = TempMaxGrowDegDay - TempBaseGrowDegDay + else + TemperatureDiff = TemperatureAirC - TempBaseGrowDegDay + endif + GrowDegreeDay = (GrowDegreeDay + TemperatureDiff * MainTimeStep / 86400.0) * IndexPlanting * IndexHarvest + GrowDegDayCnt = GrowDegreeDay + + ! Decide corn growth stage, based on Hybrid-Maize + ! PlantGrowStage = 1 : Before planting + ! PlantGrowStage = 2 : from tassel initiation to silking + ! PlantGrowStage = 3 : from silking to effective grain filling + ! PlantGrowStage = 4 : from effective grain filling to pysiological maturity + ! PlantGrowStage = 5 : GrowDegDayMax=1389 + ! PlantGrowStage = 6 : + ! PlantGrowStage = 7 : + ! PlantGrowStage = 8 : + ! GrowDegDayMax = 1389 + ! GrowDegDayMax = 1555 + ! GrowDegDayTmp = 0.41 * GrowDegDayMax + 145.4 + 150 ! from hybrid-maize + ! GrowDegDayEmerg = ((GrowDegDayTmp - 96) / 38.9 - 4) * 21 + ! GrowDegDayEmerg = 0.77 * GrowDegDayTmp + ! GrowDegDayPostVeg = GrowDegDayTmp + 170 + ! GrowDegDayPostVeg = 170 + + ! compute plant growth stage + PlantGrowStage = 1 ! MB: set PlantGrowStage = 1 (for initialization during growing season when no GDD) + if ( GrowDegDayCnt > 0.0 ) PlantGrowStage = 2 + if ( GrowDegDayCnt >= GrowDegDayEmerg ) PlantGrowStage = 3 + if ( GrowDegDayCnt >= GrowDegDayInitVeg ) PlantGrowStage = 4 + if ( GrowDegDayCnt >= GrowDegDayPostVeg ) PlantGrowStage = 5 + if ( GrowDegDayCnt >= GrowDegDayInitReprod ) PlantGrowStage = 6 + if ( GrowDegDayCnt >= GrowDegDayMature ) PlantGrowStage = 7 + if ( DayJulianInYear >= DateHarvest ) PlantGrowStage = 8 + if ( DayJulianInYear < DatePlanting ) PlantGrowStage = 1 + + end associate + + end subroutine CropGrowDegreeDay + +end module CropGrowDegreeDayMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/CropPhotosynthesisMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/CropPhotosynthesisMod.F90 new file mode 100644 index 0000000000..1a7ff70748 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/CropPhotosynthesisMod.F90 @@ -0,0 +1,109 @@ +module CropPhotosynthesisMod + +!!! Compute crop photosynthesis + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine CropPhotosynthesis(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PSN_CROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: PhotosynRad ! photosynthetically active radiation (w/m2) 1 W m-2 = 0.0864 MJ m-2 day-1 + real(kind=kind_noahmp) :: Co2AssimMax ! Maximum CO2 assimulation rate g CO2/m2/s + real(kind=kind_noahmp) :: Co2AssimTot ! CO2 Assimilation g CO2/m2/s + real(kind=kind_noahmp) :: TemperatureAirC ! air temperature degC + real(kind=kind_noahmp) :: L1 ! Three Gaussian method + real(kind=kind_noahmp) :: L2 ! Three Gaussian method + real(kind=kind_noahmp) :: L3 ! Three Gaussian method + real(kind=kind_noahmp) :: I1 ! Three Gaussian method + real(kind=kind_noahmp) :: I2 ! Three Gaussian method + real(kind=kind_noahmp) :: I3 ! Three Gaussian method + real(kind=kind_noahmp) :: A1 ! Three Gaussian method + real(kind=kind_noahmp) :: A2 ! Three Gaussian method + real(kind=kind_noahmp) :: A3 ! Three Gaussian method + +!------------------------------------------------------------------------ + associate( & + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! in, 2-m air temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! in, leaf area index, unadjusted for burying by snow + PhotosynRadFrac => noahmp%biochem%param%PhotosynRadFrac ,& ! in, Fraction of incoming radiation to photosynthetically active radiation + TempMinCarbonAssim => noahmp%biochem%param%TempMinCarbonAssim ,& ! in, Minimum temperature for CO2 assimilation [C] + TempMaxCarbonAssim => noahmp%biochem%param%TempMaxCarbonAssim ,& ! in, CO2 assim. linearly increasing until reaching this temperature [C] + TempMaxCarbonAssimMax => noahmp%biochem%param%TempMaxCarbonAssimMax ,& ! in, CO2 assim. remain at CarbonAssimRefMax until reaching this temperature [C] + CarbonAssimRefMax => noahmp%biochem%param%CarbonAssimRefMax ,& ! in, reference maximum CO2 assimilation rate + LightExtCoeff => noahmp%biochem%param%LightExtCoeff ,& ! in, light extinction coefficient + LightUseEfficiency => noahmp%biochem%param%LightUseEfficiency ,& ! in, initial light use efficiency + CarbonAssimReducFac => noahmp%biochem%param%CarbonAssimReducFac ,& ! in, CO2 assimulation reduction factor(0-1) (caused by e.g.pest,weeds) + PhotosynCrop => noahmp%biochem%flux%PhotosynCrop & ! out, crop photosynthesis [umol co2/m2/s] + ) +!------------------------------------------------------------------------ + + ! initialize + TemperatureAirC = TemperatureAir2m - 273.15 + PhotosynRad = PhotosynRadFrac * RadSwDownRefHeight * 0.0036 !w to MJ m-2 + + ! compute Maximum CO2 assimulation rate g/co2/s + if ( TemperatureAirC < TempMinCarbonAssim ) then + Co2AssimMax = 1.0e-10 + elseif ( (TemperatureAirC >= TempMinCarbonAssim) .and. (TemperatureAirC < TempMaxCarbonAssim) ) then + Co2AssimMax = (TemperatureAirC - TempMinCarbonAssim) * CarbonAssimRefMax / (TempMaxCarbonAssim - TempMinCarbonAssim) + elseif ( (TemperatureAirC >= TempMaxCarbonAssim) .and. (TemperatureAirC < TempMaxCarbonAssimMax) ) then + Co2AssimMax = CarbonAssimRefMax + else + Co2AssimMax = CarbonAssimRefMax - 0.2 * (TemperatureAir2m - TempMaxCarbonAssimMax) + endif + Co2AssimMax = max(Co2AssimMax, 0.01) + + ! compute coefficients + if ( LeafAreaIndex <= 0.05 ) then + L1 = 0.1127 * 0.05 ! use initial LeafAreaIndex(0.05), avoid error + L2 = 0.5 * 0.05 + L3 = 0.8873 * 0.05 + else + L1 = 0.1127 * LeafAreaIndex + L2 = 0.5 * LeafAreaIndex + L3 = 0.8873 * LeafAreaIndex + endif + + I1 = LightExtCoeff * PhotosynRad * exp(-LightExtCoeff * L1) + I2 = LightExtCoeff * PhotosynRad * exp(-LightExtCoeff * L2) + I3 = LightExtCoeff * PhotosynRad * exp(-LightExtCoeff * L3) + I1 = max(I1, 1.0e-10) + I2 = max(I2, 1.0e-10) + I3 = max(I3, 1.0e-10) + A1 = Co2AssimMax * (1 - exp(-LightUseEfficiency * I1 / Co2AssimMax)) + A2 = Co2AssimMax * (1 - exp(-LightUseEfficiency * I2 / Co2AssimMax)) * 1.6 + A3 = Co2AssimMax * (1 - exp(-LightUseEfficiency * I3 / Co2AssimMax)) + + ! compute photosynthesis rate + if ( LeafAreaIndex <= 0.05 ) then + Co2AssimTot = (A1 + A2 + A3) / 3.6 * 0.05 + elseif ( (LeafAreaIndex > 0.05) .and. (LeafAreaIndex <= 4.0) ) then + Co2AssimTot = (A1 + A2 + A3) / 3.6 * LeafAreaIndex + else + Co2AssimTot = (A1 + A2 + A3) / 3.6 * 4 + endif + Co2AssimTot = Co2AssimTot * CarbonAssimReducFac ! Attainable + PhotosynCrop = 6.313 * Co2AssimTot ! (1/44) * 1000000)/3600 = 6.313 + + end associate + + end subroutine CropPhotosynthesis + +end module CropPhotosynthesisMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainGlacierMod.F90 new file mode 100644 index 0000000000..3fc0bf0717 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainGlacierMod.F90 @@ -0,0 +1,173 @@ +module EnergyMainGlacierMod + +!!! Main energy module for glacier points including all energy relevant processes +!!! snow thermal property -> radiation -> ground heat flux -> snow temperature solver -> snow/ice phase change + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowCoverGlacierMod, only : SnowCoverGlacier + use GroundRoughnessPropertyGlacierMod, only : GroundRoughnessPropertyGlacier + use GroundThermalPropertyGlacierMod, only : GroundThermalPropertyGlacier + use SurfaceAlbedoGlacierMod, only : SurfaceAlbedoGlacier + use SurfaceRadiationGlacierMod, only : SurfaceRadiationGlacier + use SurfaceEmissivityGlacierMod, only : SurfaceEmissivityGlacier + use ResistanceGroundEvaporationGlacierMod, only : ResistanceGroundEvaporationGlacier + use PsychrometricVariableGlacierMod, only : PsychrometricVariableGlacier + use SurfaceEnergyFluxGlacierMod, only : SurfaceEnergyFluxGlacier + use GlacierTemperatureMainMod, only : GlacierTemperatureMain + use GlacierPhaseChangeMod, only : GlacierPhaseChange + + implicit none + +contains + + subroutine EnergyMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ENERGY_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + +! -------------------------------------------------------------------- + associate( & + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + TemperatureSfc => noahmp%energy%state%TemperatureSfc ,& ! inout, surface temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! inout, ground temperature [K] + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity at bare surface + SpecHumiditySfcMean => noahmp%energy%state%SpecHumiditySfcMean ,& ! inout, specific humidity at surface grid mean + ExchCoeffMomSfc => noahmp%energy%state%ExchCoeffMomSfc ,& ! inout, exchange coefficient [m/s] for momentum, surface, grid mean + ExchCoeffShSfc => noahmp%energy%state%ExchCoeffShSfc ,& ! inout, exchange coefficient [m/s] for heat, surface, grid mean + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + RoughLenMomSfcToAtm => noahmp%energy%state%RoughLenMomSfcToAtm ,& ! out, roughness length, momentum, surface, sent to coupled model + WindStressEwSfc => noahmp%energy%state%WindStressEwSfc ,& ! out, wind stress: east-west [N/m2] grid mean + WindStressNsSfc => noahmp%energy%state%WindStressNsSfc ,& ! out, wind stress: north-south [N/m2] grid mean + TemperatureRadSfc => noahmp%energy%state%TemperatureRadSfc ,& ! out, radiative temperature [K] + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! out, grid mean 2-m air temperature [K] + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + EmissivitySfc => noahmp%energy%state%EmissivitySfc ,& ! out, surface emissivity + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length, momentum, ground [m] + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m water vapor mixing ratio + SpecHumidity2m => noahmp%energy%state%SpecHumidity2m ,& ! out, grid mean 2-m water vapor mixing ratio + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! out, bare ground temperature [K] + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + AlbedoSfc => noahmp%energy%state%AlbedoSfc ,& ! out, total shortwave surface albedo + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! out, total reflected solar radiation [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! out, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! out, total sensible heat [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! out, total ground latent heat [W/m2] (+ to atm) + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! out, total ground heat flux [W/m2] (+ to soil/snow) + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! out, precipitation advected heat - total [W/m2] + RadLwEmitSfc => noahmp%energy%flux%RadLwEmitSfc ,& ! out, emitted outgoing IR [W/m2] + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd & ! out, bare ground heat flux [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! glaicer snow cover fraction + call SnowCoverGlacier(noahmp) + + ! ground and surface roughness length and reference height + call GroundRoughnessPropertyGlacier(noahmp) + + ! Thermal properties of snow and glacier ice + call GroundThermalPropertyGlacier(noahmp) + + ! Glacier surface shortwave abeldo + call SurfaceAlbedoGlacier(noahmp) + + ! Glacier surface shortwave radiation + call SurfaceRadiationGlacier(noahmp) + + ! longwave emissivity for glacier surface + call SurfaceEmissivityGlacier(noahmp) + + ! glacier surface resistance for ground evaporation/sublimation + call ResistanceGroundEvaporationGlacier(noahmp) + + ! set psychrometric variable/constant + call PsychrometricVariableGlacier(noahmp) + + ! temperatures and energy fluxes of glacier ground + TemperatureGrdBare = TemperatureGrd + ExchCoeffMomBare = ExchCoeffMomSfc + ExchCoeffShBare = ExchCoeffShSfc + call SurfaceEnergyFluxGlacier(noahmp) + + ! assign glacier bare ground quantity to grid-level quantity + ! Energy balance at glacier (bare) ground: + ! RadSwAbsGrd + HeatPrecipAdvBareGrd = RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd + WindStressEwSfc = WindStressEwBare + WindStressNsSfc = WindStressNsBare + RadLwNetSfc = RadLwNetBareGrd + HeatSensibleSfc = HeatSensibleBareGrd + HeatLatentGrd = HeatLatentBareGrd + HeatGroundTot = HeatGroundBareGrd + TemperatureGrd = TemperatureGrdBare + TemperatureAir2m = TemperatureAir2mBare + HeatPrecipAdvSfc = HeatPrecipAdvBareGrd + TemperatureSfc = TemperatureGrd + ExchCoeffMomSfc = ExchCoeffMomBare + ExchCoeffShSfc = ExchCoeffShBare + SpecHumiditySfcMean = SpecHumiditySfc + SpecHumidity2m = SpecHumidity2mBare + RoughLenMomSfcToAtm = RoughLenMomGrd + + ! emitted longwave radiation and physical check + RadLwEmitSfc = RadLwDownRefHeight + RadLwNetSfc + if ( RadLwEmitSfc <= 0.0 ) then + write(*,*) "emitted longwave <0; skin T may be wrong due to inconsistent" + write(*,*) "RadLwDownRefHeight = ", RadLwDownRefHeight, "RadLwNetSfc = ", RadLwNetSfc, "SnowDepth = ", SnowDepth + stop "Error: Longwave radiation budget problem in NoahMP LSM" + endif + + ! radiative temperature: subtract from the emitted IR the + ! reflected portion of the incoming longwave radiation, so just + ! considering the IR originating/emitted in the ground system. + ! Old TemperatureRadSfc calculation not taking into account Emissivity: + ! TemperatureRadSfc = (RadLwEmitSfc/ConstStefanBoltzmann)**0.25 + TemperatureRadSfc = ((RadLwEmitSfc - (1.0 - EmissivitySfc)*RadLwDownRefHeight) / & + (EmissivitySfc * ConstStefanBoltzmann)) ** 0.25 + + ! compute snow and glacier ice temperature + call GlacierTemperatureMain(noahmp) + + ! adjusting suface temperature based on snow condition + if ( OptSnowSoilTempTime == 2 ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrd > ConstFreezePoint) ) then + TemperatureGrdBare = ConstFreezePoint + TemperatureGrd = TemperatureGrdBare + TemperatureSfc = TemperatureGrdBare + endif + endif + + ! Phase change and Energy released or consumed by snow & glacier ice + call GlacierPhaseChange(noahmp) + + ! update total surface albedo + if ( RadSwDownRefHeight > 0.0 ) then + AlbedoSfc = RadSwReflSfc / RadSwDownRefHeight + else + AlbedoSfc = undefined_real + endif + + end associate + + end subroutine EnergyMainGlacier + +end module EnergyMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainMod.F90 new file mode 100644 index 0000000000..0bd1df9ff2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyMainMod.F90 @@ -0,0 +1,350 @@ +module EnergyMainMod + +!!! Main energy module including all energy relevant processes +!!! soil/snow thermal property -> radiation -> ground/vegtation heat flux -> snow/soil temperature solver -> soil/snow phase change +! +! -------------------------------------------------------------------------------------------------- +! NoahMP uses different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. It uses 'tile' approach to compute turbulent fluxes, while it uses two-stream approx. +! to compute radiation transfer. Tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. The +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / O O O O O O O O / / +! / | | | | | | | | / / +! / O O O O O O O O / / +! / | | |tile1| | | | / tile2 / +! / O O O O O O O O / bare / +! / | | | vegetated | | / / +! / O O O O O O O O / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (Yang and Friedl, 2003, JGR; Niu ang Yang, 2004, JGR) +! -------------------------------------- two-stream treats leaves as +! / O O O O O O O O / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / O O O O O O O O / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / O O O O O O O O / the left figure). We assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / O O O O O O O O / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. The 'tile' +! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowCoverGroundNiu07Mod, only : SnowCoverGroundNiu07 + use GroundRoughnessPropertyMod, only : GroundRoughnessProperty + use GroundThermalPropertyMod, only : GroundThermalProperty + use SurfaceAlbedoMod, only : SurfaceAlbedo + use SurfaceRadiationMod, only : SurfaceRadiation + use SurfaceEmissivityMod, only : SurfaceEmissivity + use SoilWaterTranspirationMod, only : SoilWaterTranspiration + use ResistanceGroundEvaporationMod, only : ResistanceGroundEvaporation + use PsychrometricVariableMod, only : PsychrometricVariable + use SurfaceEnergyFluxVegetatedMod, only : SurfaceEnergyFluxVegetated + use SurfaceEnergyFluxBareGroundMod, only : SurfaceEnergyFluxBareGround + use SoilSnowTemperatureMainMod, only : SoilSnowTemperatureMain + use SoilSnowWaterPhaseChangeMod, only : SoilSnowWaterPhaseChange + + implicit none + +contains + + subroutine EnergyMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ENERGY +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + logical :: FlagVegSfc ! flag: true if vegetated surface + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + RadSwDownRefHeight => noahmp%forcing%RadSwDownRefHeight ,& ! in, downward shortwave radiation [W/m2] at reference height + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + FlagCropland => noahmp%config%domain%FlagCropland ,& ! in, flag to identify croplands + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to determine if calculating soil processes + NumSoilTimeStep => noahmp%config%domain%NumSoilTimeStep ,& ! in, number of time step for calculating soil processes + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, soil process timestep [s] + IrriFracThreshold => noahmp%water%param%IrriFracThreshold ,& ! in, irrigation fraction parameter + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, total input irrigation fraction + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + HeatLatentIrriEvap => noahmp%energy%flux%HeatLatentIrriEvap ,& ! in, latent heating due to sprinkler evaporation [W/m2] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! in, precipitation advected heat - vegetation net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! in, precipitation advected heat - under canopy net [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + TemperatureSfc => noahmp%energy%state%TemperatureSfc ,& ! inout, surface temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! inout, ground temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! inout, vegetation temperature [K] + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity [kg/kg] at bare/veg/urban surface + SpecHumiditySfcMean => noahmp%energy%state%SpecHumiditySfcMean ,& ! inout, specific humidity [kg/kg] at surface grid mean + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! inout, canopy air vapor pressure [Pa] + ExchCoeffMomSfc => noahmp%energy%state%ExchCoeffMomSfc ,& ! inout, exchange coefficient [m/s] for momentum, surface, grid mean + ExchCoeffShSfc => noahmp%energy%state%ExchCoeffShSfc ,& ! inout, exchange coefficient [m/s] for heat, surface, grid mean + HeatGroundTotAcc => noahmp%energy%flux%HeatGroundTotAcc ,& ! inout, accumulated total ground heat flux per soil timestep [W/m2 * dt_soil/dt_main] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + RoughLenMomSfcToAtm => noahmp%energy%state%RoughLenMomSfcToAtm ,& ! out, roughness length, momentum, surface, sent to coupled model + WindStressEwSfc => noahmp%energy%state%WindStressEwSfc ,& ! out, wind stress: east-west [N/m2] grid mean + WindStressNsSfc => noahmp%energy%state%WindStressNsSfc ,& ! out, wind stress: north-south [N/m2] grid mean + TemperatureRadSfc => noahmp%energy%state%TemperatureRadSfc ,& ! out, surface radiative temperature [K] + TemperatureAir2m => noahmp%energy%state%TemperatureAir2m ,& ! out, grid mean 2-m air temperature [K] + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + TemperatureAir2mVeg => noahmp%energy%state%TemperatureAir2mVeg ,& ! out, 2 m height air temperature [K], vegetated + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! out, sunlit leaf area index, one-sided [m2/m2] + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! out, shaded leaf area index, one-sided [m2/m2] + EmissivitySfc => noahmp%energy%state%EmissivitySfc ,& ! out, surface emissivity + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! out, one-sided leaf+stem area index [m2/m2] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! out, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length [m], momentum, ground + WindStressEwVeg => noahmp%energy%state%WindStressEwVeg ,& ! out, wind stress: east-west [N/m2] above canopy + WindStressNsVeg => noahmp%energy%state%WindStressNsVeg ,& ! out, wind stress: north-south [N/m2] above canopy + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + SpecHumidity2mVeg => noahmp%energy%state%SpecHumidity2mVeg ,& ! out, water vapor mixing ratio at 2m vegetated + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m water vapor mixing ratio + SpecHumidity2m => noahmp%energy%state%SpecHumidity2m ,& ! out, grid mean 2-m water vapor mixing ratio + TemperatureGrdVeg => noahmp%energy%state%TemperatureGrdVeg ,& ! out, vegetated ground (below-canopy) temperature [K] + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! out, bare ground temperature [K] + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, vegetated + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, vegetated + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + ExchCoeffShLeaf => noahmp%energy%state%ExchCoeffShLeaf ,& ! out, leaf sensible heat exchange coeff [m/s], leaf to canopy air + ExchCoeffShUndCan => noahmp%energy%state%ExchCoeffShUndCan ,& ! out, under canopy sensible heat exchange coefficient [m/s] + ExchCoeffSh2mVeg => noahmp%energy%state%ExchCoeffSh2mVeg ,& ! out, 2m sensible heat exchange coefficient [m/s] vegetated + AlbedoSfc => noahmp%energy%state%AlbedoSfc ,& ! out, total shortwave surface albedo + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! out, total reflected solar radiation [W/m2] + RadLwNetSfc => noahmp%energy%flux%RadLwNetSfc ,& ! out, total net longwave rad [W/m2] (+ to atm) + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! out, total sensible heat [W/m2] (+ to atm) + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! out, total ground latent heat [W/m2] (+ to atm) + HeatLatentCanopy => noahmp%energy%flux%HeatLatentCanopy ,& ! out, canopy latent heat flux [W/m2] (+ to atm) + HeatLatentTransp => noahmp%energy%flux%HeatLatentTransp ,& ! out, latent heat flux from transpiration [W/m2] (+ to atm) + RadPhotoActAbsCan => noahmp%energy%flux%RadPhotoActAbsCan ,& ! out, total photosyn. active energy [W/m2) absorbed by canopy + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! out, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! out, average absorbed par for shaded leaves [W/m2] + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! out, total ground heat flux [W/m2] (+ to soil/snow) + HeatPrecipAdvSfc => noahmp%energy%flux%HeatPrecipAdvSfc ,& ! out, precipitation advected heat - total [W/m2] + RadLwEmitSfc => noahmp%energy%flux%RadLwEmitSfc ,& ! out, emitted outgoing IR [W/m2] + RadLwNetCanopy => noahmp%energy%flux%RadLwNetCanopy ,& ! out, canopy net longwave radiation [W/m2] (+ to atm) + RadLwNetVegGrd => noahmp%energy%flux%RadLwNetVegGrd ,& ! out, ground net longwave radiation [W/m2] (+ to atm) + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleCanopy => noahmp%energy%flux%HeatSensibleCanopy ,& ! out, canopy sensible heat flux [W/m2] (+ to atm) + HeatSensibleVegGrd => noahmp%energy%flux%HeatSensibleVegGrd ,& ! out, vegetated ground sensible heat flux [W/m2] (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentVegGrd => noahmp%energy%flux%HeatLatentVegGrd ,& ! out, ground evaporation heat flux [W/m2] (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatLatentCanEvap => noahmp%energy%flux%HeatLatentCanEvap ,& ! out, canopy evaporation heat flux [W/m2] (+ to atm) + HeatLatentCanTransp => noahmp%energy%flux%HeatLatentCanTransp ,& ! out, canopy transpiration heat flux [W/m2] (+ to atm) + HeatGroundVegGrd => noahmp%energy%flux%HeatGroundVegGrd ,& ! out, vegetated ground heat [W/m2] (+ to soil/snow) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd ,& ! out, bare ground heat flux [W/m2] (+ to soil/snow) + HeatCanStorageChg => noahmp%energy%flux%HeatCanStorageChg ,& ! out, canopy heat storage change [W/m2] + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot ,& ! out, energy influx from soil bottom [J/m2] during soil timestep + HeatGroundTotMean => noahmp%energy%flux%HeatGroundTotMean ,& ! out, mean ground heat flux during soil timestep [W/m2] + PhotosynTotal => noahmp%biochem%flux%PhotosynTotal ,& ! out, total leaf photosynthesis [umol co2 /m2 /s] + PhotosynLeafSunlit => noahmp%biochem%flux%PhotosynLeafSunlit ,& ! out, sunlit leaf photosynthesis [umol co2 /m2 /s] + PhotosynLeafShade => noahmp%biochem%flux%PhotosynLeafShade & ! out, shaded leaf photosynthesis [umol co2 /m2 /s] + ) +! ---------------------------------------------------------------------- + + ! initialization + WindStressEwVeg = 0.0 + WindStressNsVeg = 0.0 + RadLwNetCanopy = 0.0 + HeatSensibleCanopy = 0.0 + RadLwNetVegGrd = 0.0 + HeatSensibleVegGrd = 0.0 + HeatLatentVegGrd = 0.0 + HeatLatentCanEvap = 0.0 + HeatLatentCanTransp = 0.0 + HeatGroundVegGrd = 0.0 + PhotosynLeafSunlit = 0.0 + PhotosynLeafShade = 0.0 + TemperatureAir2mVeg = 0.0 + SpecHumidity2mVeg = 0.0 + ExchCoeffShAbvCan = 0.0 + ExchCoeffShLeaf = 0.0 + ExchCoeffShUndCan = 0.0 + ExchCoeffSh2mVeg = 0.0 + HeatPrecipAdvSfc = 0.0 + HeatCanStorageChg = 0.0 + + ! vegetated or non-vegetated + VegAreaIndEff = LeafAreaIndEff + StemAreaIndEff + FlagVegSfc = .false. + if ( VegAreaIndEff > 0.0 ) FlagVegSfc = .true. + + ! ground snow cover fraction [Niu and Yang, 2007, JGR] + call SnowCoverGroundNiu07(noahmp) + + ! ground and surface roughness length and reference height + call GroundRoughnessProperty(noahmp, FlagVegSfc) + + ! Thermal properties of soil, snow, lake, and frozen soil + call GroundThermalProperty(noahmp) + + ! Surface shortwave albedo: ground and canopy radiative transfer + call SurfaceAlbedo(noahmp) + + ! Surface shortwave radiation: absorbed & reflected by the ground and canopy + call SurfaceRadiation(noahmp) + + ! longwave emissivity for vegetation, ground, total net surface + call SurfaceEmissivity(noahmp) + + ! soil water transpiration factor controlling stomatal resistance and evapotranspiration + call SoilWaterTranspiration(noahmp) + + ! soil surface resistance for ground evaporation/sublimation + call ResistanceGroundEvaporation(noahmp) + + ! set psychrometric variable/constant + call PsychrometricVariable(noahmp) + + ! temperatures and energy fluxes of canopy and below-canopy ground + if ( (FlagVegSfc .eqv. .true.) .and. (VegFrac > 0) ) then ! vegetated portion of the grid + TemperatureGrdVeg = TemperatureGrd + ExchCoeffMomAbvCan = ExchCoeffMomSfc + ExchCoeffShAbvCan = ExchCoeffShSfc + call SurfaceEnergyFluxVegetated(noahmp) + endif + + ! temperatures and energy fluxes of bare ground + TemperatureGrdBare = TemperatureGrd + ExchCoeffMomBare = ExchCoeffMomSfc + ExchCoeffShBare = ExchCoeffShSfc + call SurfaceEnergyFluxBareGround(noahmp) + + ! compute grid mean quantities by weighting vegetated and bare portions + ! Energy balance at vege canopy: + ! RadSwAbsVeg = (RadLwNetCanopy + HeatSensibleCanopy + HeatLatentCanEvap + HeatLatentCanTransp) * VegFrac at VegFrac + ! Energy balance at vege ground: + ! RadSwAbsGrd * VegFrac = (RadLwNetVegGrd + HeatSensibleVegGrd + HeatLatentVegGrd + HeatGroundVegGrd) * VegFrac at VegFrac + ! Energy balance at bare ground: + ! RadSwAbsGrd * (1-VegFrac) = (RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd) * (1-VegFrac) at 1-VegFrac + if ( (FlagVegSfc .eqv. .true.) .and. (VegFrac > 0) ) then + WindStressEwSfc = VegFrac * WindStressEwVeg + (1.0 - VegFrac) * WindStressEwBare + WindStressNsSfc = VegFrac * WindStressNsVeg + (1.0 - VegFrac) * WindStressNsBare + RadLwNetSfc = VegFrac * RadLwNetVegGrd + (1.0 - VegFrac) * RadLwNetBareGrd + RadLwNetCanopy + HeatSensibleSfc = VegFrac * HeatSensibleVegGrd + (1.0 - VegFrac) * HeatSensibleBareGrd + HeatSensibleCanopy + HeatLatentGrd = VegFrac * HeatLatentVegGrd + (1.0 - VegFrac) * HeatLatentBareGrd + HeatGroundTot = VegFrac * HeatGroundVegGrd + (1.0 - VegFrac) * HeatGroundBareGrd + HeatLatentCanopy = HeatLatentCanEvap + HeatLatentTransp = HeatLatentCanTransp + HeatPrecipAdvSfc = VegFrac * HeatPrecipAdvVegGrd + (1.0 - VegFrac) * HeatPrecipAdvBareGrd + HeatPrecipAdvCanopy + TemperatureGrd = VegFrac * TemperatureGrdVeg + (1.0 - VegFrac) * TemperatureGrdBare + TemperatureAir2m = VegFrac * TemperatureAir2mVeg + (1.0 - VegFrac) * TemperatureAir2mBare + TemperatureSfc = VegFrac * TemperatureCanopy + (1.0 - VegFrac) * TemperatureGrdBare + ExchCoeffMomSfc = VegFrac * ExchCoeffMomAbvCan + (1.0 - VegFrac) * ExchCoeffMomBare ! better way to average? + ExchCoeffShSfc = VegFrac * ExchCoeffShAbvCan + (1.0 - VegFrac) * ExchCoeffShBare + SpecHumidity2m = VegFrac * SpecHumidity2mVeg + (1.0 - VegFrac) * SpecHumidity2mBare + SpecHumiditySfcMean = VegFrac * (PressureVaporCanAir * 0.622 / & + (PressureAirRefHeight - 0.378*PressureVaporCanAir)) + (1.0 - VegFrac) * SpecHumiditySfc + RoughLenMomSfcToAtm = RoughLenMomSfc + else + WindStressEwSfc = WindStressEwBare + WindStressNsSfc = WindStressNsBare + RadLwNetSfc = RadLwNetBareGrd + HeatSensibleSfc = HeatSensibleBareGrd + HeatLatentGrd = HeatLatentBareGrd + HeatGroundTot = HeatGroundBareGrd + TemperatureGrd = TemperatureGrdBare + TemperatureAir2m = TemperatureAir2mBare + HeatLatentCanopy = 0.0 + HeatLatentTransp = 0.0 + HeatPrecipAdvSfc = HeatPrecipAdvBareGrd + TemperatureSfc = TemperatureGrd + ExchCoeffMomSfc = ExchCoeffMomBare + ExchCoeffShSfc = ExchCoeffShBare + SpecHumiditySfcMean = SpecHumiditySfc + SpecHumidity2m = SpecHumidity2mBare + ResistanceStomataSunlit = 0.0 + ResistanceStomataShade = 0.0 + TemperatureGrdVeg = TemperatureGrdBare + ExchCoeffShAbvCan = ExchCoeffShBare + RoughLenMomSfcToAtm = RoughLenMomGrd + endif + + ! emitted longwave radiation and physical check + RadLwEmitSfc = RadLwDownRefHeight + RadLwNetSfc + if ( RadLwEmitSfc <= 0.0 ) then + write(*,*) "emitted longwave <0; skin T may be wrong due to inconsistent" + write(*,*) "input of VegFracGreen with LeafAreaIndex" + write(*,*) "VegFrac = ", VegFrac, "VegAreaIndEff = ", VegAreaIndEff, & + "TemperatureCanopy = ", TemperatureCanopy, "TemperatureGrd = ", TemperatureGrd + write(*,*) "RadLwDownRefHeight = ", RadLwDownRefHeight, "RadLwNetSfc = ", RadLwNetSfc, "SnowDepth = ", SnowDepth + stop "Error: Longwave radiation budget problem in NoahMP LSM" + endif + + ! radiative temperature: subtract from the emitted IR the + ! reflected portion of the incoming longwave radiation, so just + ! considering the IR originating/emitted in the canopy/ground system. + ! Old TemperatureRadSfc calculation not taking into account Emissivity: + ! TemperatureRadSfc = (RadLwEmitSfc/ConstStefanBoltzmann)**0.25 + TemperatureRadSfc = ((RadLwEmitSfc - (1.0-EmissivitySfc)*RadLwDownRefHeight) / (EmissivitySfc*ConstStefanBoltzmann))**0.25 + + ! other photosynthesis related quantities for biochem process + RadPhotoActAbsCan = RadPhotoActAbsSunlit * LeafAreaIndSunlit + RadPhotoActAbsShade * LeafAreaIndShade + PhotosynTotal = PhotosynLeafSunlit * LeafAreaIndSunlit + PhotosynLeafShade * LeafAreaIndShade + + ! compute snow and soil layer temperature at soil timestep + HeatFromSoilBot = 0.0 + HeatGroundTotAcc = HeatGroundTotAcc + HeatGroundTot + if ( FlagSoilProcess .eqv. .true. ) then + HeatGroundTotMean = HeatGroundTotAcc / NumSoilTimeStep + call SoilSnowTemperatureMain(noahmp) + endif ! FlagSoilProcess + + ! adjusting suface temperature based on snow condition + if ( OptSnowSoilTempTime == 2 ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrd > ConstFreezePoint) ) then + TemperatureGrdVeg = ConstFreezePoint + TemperatureGrdBare = ConstFreezePoint + if ( (FlagVegSfc .eqv. .true.) .and. (VegFrac > 0) ) then + TemperatureGrd = VegFrac * TemperatureGrdVeg + (1.0 - VegFrac) * TemperatureGrdBare + TemperatureSfc = VegFrac * TemperatureCanopy + (1.0 - VegFrac) * TemperatureGrdBare + else + TemperatureGrd = TemperatureGrdBare + TemperatureSfc = TemperatureGrdBare + endif + endif + endif + + ! Phase change and Energy released or consumed by snow & frozen soil + call SoilSnowWaterPhaseChange(noahmp) + + ! update sensible heat flux due to sprinkler irrigation evaporation + if ( (FlagCropland .eqv. .true.) .and. (IrrigationFracGrid >= IrriFracThreshold) ) & + HeatSensibleSfc = HeatSensibleSfc - HeatLatentIrriEvap + + ! update total surface albedo + if ( RadSwDownRefHeight > 0.0 ) then + AlbedoSfc = RadSwReflSfc / RadSwDownRefHeight + else + AlbedoSfc = undefined_real + endif + + end associate + + end subroutine EnergyMain + +end module EnergyMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarInitMod.F90 new file mode 100644 index 0000000000..16484712b1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarInitMod.F90 @@ -0,0 +1,398 @@ +module EnergyVarInitMod + +!!! Initialize column (1-D) Noah-MP energy variables +!!! Energy variables should be first defined in EnergyVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine EnergyVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& + NumSwRadBand => noahmp%config%domain%NumSwRadBand & + ) + + ! energy state variables + noahmp%energy%state%FlagFrozenCanopy = .false. + noahmp%energy%state%FlagFrozenGround = .false. + noahmp%energy%state%LeafAreaIndEff = undefined_real + noahmp%energy%state%StemAreaIndEff = undefined_real + noahmp%energy%state%LeafAreaIndex = undefined_real + noahmp%energy%state%StemAreaIndex = undefined_real + noahmp%energy%state%VegAreaIndEff = undefined_real + noahmp%energy%state%VegFrac = undefined_real + noahmp%energy%state%PressureVaporRefHeight = undefined_real + noahmp%energy%state%SnowAgeFac = undefined_real + noahmp%energy%state%SnowAgeNondim = undefined_real + noahmp%energy%state%AlbedoSnowPrev = undefined_real + noahmp%energy%state%VegAreaProjDir = undefined_real + noahmp%energy%state%GapBtwCanopy = undefined_real + noahmp%energy%state%GapInCanopy = undefined_real + noahmp%energy%state%GapCanopyDif = undefined_real + noahmp%energy%state%GapCanopyDir = undefined_real + noahmp%energy%state%CanopySunlitFrac = undefined_real + noahmp%energy%state%CanopyShadeFrac = undefined_real + noahmp%energy%state%LeafAreaIndSunlit = undefined_real + noahmp%energy%state%LeafAreaIndShade = undefined_real + noahmp%energy%state%VapPresSatCanopy = undefined_real + noahmp%energy%state%VapPresSatGrdVeg = undefined_real + noahmp%energy%state%VapPresSatGrdBare = undefined_real + noahmp%energy%state%VapPresSatCanTempD = undefined_real + noahmp%energy%state%VapPresSatGrdVegTempD = undefined_real + noahmp%energy%state%VapPresSatGrdBareTempD = undefined_real + noahmp%energy%state%PressureVaporCanAir = undefined_real + noahmp%energy%state%PressureAtmosCO2 = undefined_real + noahmp%energy%state%PressureAtmosO2 = undefined_real + noahmp%energy%state%ResistanceStomataSunlit = undefined_real + noahmp%energy%state%ResistanceStomataShade = undefined_real + noahmp%energy%state%DensityAirRefHeight = undefined_real + noahmp%energy%state%TemperatureCanopyAir = undefined_real + noahmp%energy%state%ZeroPlaneDispSfc = undefined_real + noahmp%energy%state%ZeroPlaneDispGrd = undefined_real + noahmp%energy%state%RoughLenMomGrd = undefined_real + noahmp%energy%state%RoughLenMomSfc = undefined_real + noahmp%energy%state%CanopyHeight = undefined_real + noahmp%energy%state%WindSpdCanopyTop = undefined_real + noahmp%energy%state%RoughLenShCanopy = undefined_real + noahmp%energy%state%RoughLenShVegGrd = undefined_real + noahmp%energy%state%RoughLenShBareGrd = undefined_real + noahmp%energy%state%FrictionVelVeg = undefined_real + noahmp%energy%state%FrictionVelBare = undefined_real + noahmp%energy%state%WindExtCoeffCanopy = undefined_real + noahmp%energy%state%MoStabParaUndCan = undefined_real + noahmp%energy%state%MoStabParaAbvCan = undefined_real + noahmp%energy%state%MoStabParaBare = undefined_real + noahmp%energy%state%MoStabParaVeg2m = undefined_real + noahmp%energy%state%MoStabParaBare2m = undefined_real + noahmp%energy%state%MoLengthUndCan = undefined_real + noahmp%energy%state%MoLengthAbvCan = undefined_real + noahmp%energy%state%MoLengthBare = undefined_real + noahmp%energy%state%MoStabCorrShUndCan = undefined_real + noahmp%energy%state%MoStabCorrMomAbvCan = undefined_real + noahmp%energy%state%MoStabCorrShAbvCan = undefined_real + noahmp%energy%state%MoStabCorrMomVeg2m = undefined_real + noahmp%energy%state%MoStabCorrShVeg2m = undefined_real + noahmp%energy%state%MoStabCorrShBare = undefined_real + noahmp%energy%state%MoStabCorrMomBare = undefined_real + noahmp%energy%state%MoStabCorrMomBare2m = undefined_real + noahmp%energy%state%MoStabCorrShBare2m = undefined_real + noahmp%energy%state%ExchCoeffMomSfc = undefined_real + noahmp%energy%state%ExchCoeffMomAbvCan = undefined_real + noahmp%energy%state%ExchCoeffMomBare = undefined_real + noahmp%energy%state%ExchCoeffShSfc = undefined_real + noahmp%energy%state%ExchCoeffShBare = undefined_real + noahmp%energy%state%ExchCoeffShAbvCan = undefined_real + noahmp%energy%state%ExchCoeffShLeaf = undefined_real + noahmp%energy%state%ExchCoeffShUndCan = undefined_real + noahmp%energy%state%ExchCoeffSh2mVegMo = undefined_real + noahmp%energy%state%ExchCoeffSh2mBareMo = undefined_real + noahmp%energy%state%ExchCoeffSh2mVeg = undefined_real + noahmp%energy%state%ExchCoeffSh2mBare = undefined_real + noahmp%energy%state%ExchCoeffLhAbvCan = undefined_real + noahmp%energy%state%ExchCoeffLhTransp = undefined_real + noahmp%energy%state%ExchCoeffLhEvap = undefined_real + noahmp%energy%state%ExchCoeffLhUndCan = undefined_real + noahmp%energy%state%ResistanceMomUndCan = undefined_real + noahmp%energy%state%ResistanceShUndCan = undefined_real + noahmp%energy%state%ResistanceLhUndCan = undefined_real + noahmp%energy%state%ResistanceMomAbvCan = undefined_real + noahmp%energy%state%ResistanceShAbvCan = undefined_real + noahmp%energy%state%ResistanceLhAbvCan = undefined_real + noahmp%energy%state%ResistanceMomBareGrd = undefined_real + noahmp%energy%state%ResistanceShBareGrd = undefined_real + noahmp%energy%state%ResistanceLhBareGrd = undefined_real + noahmp%energy%state%ResistanceLeafBoundary = undefined_real + noahmp%energy%state%TemperaturePotRefHeight = undefined_real + noahmp%energy%state%WindSpdRefHeight = undefined_real + noahmp%energy%state%FrictionVelVertVeg = undefined_real + noahmp%energy%state%FrictionVelVertBare = undefined_real + noahmp%energy%state%EmissivityVeg = undefined_real + noahmp%energy%state%EmissivityGrd = undefined_real + noahmp%energy%state%ResistanceGrdEvap = undefined_real + noahmp%energy%state%PsychConstCanopy = undefined_real + noahmp%energy%state%LatHeatVapCanopy = undefined_real + noahmp%energy%state%PsychConstGrd = undefined_real + noahmp%energy%state%LatHeatVapGrd = undefined_real + noahmp%energy%state%RelHumidityGrd = undefined_real + noahmp%energy%state%SpecHumiditySfcMean = undefined_real + noahmp%energy%state%SpecHumiditySfc = undefined_real + noahmp%energy%state%SpecHumidity2mVeg = undefined_real + noahmp%energy%state%SpecHumidity2mBare = undefined_real + noahmp%energy%state%SpecHumidity2m = undefined_real + noahmp%energy%state%TemperatureSfc = undefined_real + noahmp%energy%state%TemperatureGrd = undefined_real + noahmp%energy%state%TemperatureCanopy = undefined_real + noahmp%energy%state%TemperatureGrdVeg = undefined_real + noahmp%energy%state%TemperatureGrdBare = undefined_real + noahmp%energy%state%TemperatureRootZone = undefined_real + noahmp%energy%state%WindStressEwVeg = undefined_real + noahmp%energy%state%WindStressNsVeg = undefined_real + noahmp%energy%state%WindStressEwBare = undefined_real + noahmp%energy%state%WindStressNsBare = undefined_real + noahmp%energy%state%WindStressEwSfc = undefined_real + noahmp%energy%state%WindStressNsSfc = undefined_real + noahmp%energy%state%TemperatureAir2mVeg = undefined_real + noahmp%energy%state%TemperatureAir2mBare = undefined_real + noahmp%energy%state%TemperatureAir2m = undefined_real + noahmp%energy%state%CanopyFracSnowBury = undefined_real + noahmp%energy%state%DepthSoilTempBotToSno = undefined_real + noahmp%energy%state%RoughLenMomSfcToAtm = undefined_real + noahmp%energy%state%TemperatureRadSfc = undefined_real + noahmp%energy%state%EmissivitySfc = undefined_real + noahmp%energy%state%AlbedoSfc = undefined_real + noahmp%energy%state%EnergyBalanceError = undefined_real + noahmp%energy%state%RadSwBalanceError = undefined_real + noahmp%energy%state%RefHeightAboveGrd = undefined_real + + if ( .not. allocated(noahmp%energy%state%TemperatureSoilSnow) ) & + allocate( noahmp%energy%state%TemperatureSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%ThermConductSoilSnow) ) & + allocate( noahmp%energy%state%ThermConductSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacSoilSnow) ) & + allocate( noahmp%energy%state%HeatCapacSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%PhaseChgFacSoilSnow) ) & + allocate( noahmp%energy%state%PhaseChgFacSoilSnow(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacVolSnow) ) & + allocate( noahmp%energy%state%HeatCapacVolSnow(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%energy%state%ThermConductSnow) ) & + allocate( noahmp%energy%state%ThermConductSnow(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacVolSoil) ) & + allocate( noahmp%energy%state%HeatCapacVolSoil(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%ThermConductSoil) ) & + allocate( noahmp%energy%state%ThermConductSoil(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%HeatCapacGlaIce) ) & + allocate( noahmp%energy%state%HeatCapacGlaIce(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%ThermConductGlaIce) ) & + allocate( noahmp%energy%state%ThermConductGlaIce(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSnowDir) ) & + allocate( noahmp%energy%state%AlbedoSnowDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSnowDif) ) & + allocate( noahmp%energy%state%AlbedoSnowDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSoilDir) ) & + allocate( noahmp%energy%state%AlbedoSoilDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSoilDif) ) & + allocate( noahmp%energy%state%AlbedoSoilDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoGrdDir) ) & + allocate( noahmp%energy%state%AlbedoGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoGrdDif) ) & + allocate( noahmp%energy%state%AlbedoGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%ReflectanceVeg) ) & + allocate( noahmp%energy%state%ReflectanceVeg(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%TransmittanceVeg) ) & + allocate( noahmp%energy%state%TransmittanceVeg(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSfcDir) ) & + allocate( noahmp%energy%state%AlbedoSfcDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%state%AlbedoSfcDif) ) & + allocate( noahmp%energy%state%AlbedoSfcDif(1:NumSwRadBand) ) + + noahmp%energy%state%TemperatureSoilSnow (:) = undefined_real + noahmp%energy%state%ThermConductSoilSnow(:) = undefined_real + noahmp%energy%state%HeatCapacSoilSnow (:) = undefined_real + noahmp%energy%state%PhaseChgFacSoilSnow (:) = undefined_real + noahmp%energy%state%HeatCapacVolSnow (:) = undefined_real + noahmp%energy%state%ThermConductSnow (:) = undefined_real + noahmp%energy%state%HeatCapacVolSoil (:) = undefined_real + noahmp%energy%state%ThermConductSoil (:) = undefined_real + noahmp%energy%state%HeatCapacGlaIce (:) = undefined_real + noahmp%energy%state%ThermConductGlaIce (:) = undefined_real + noahmp%energy%state%AlbedoSnowDir (:) = undefined_real + noahmp%energy%state%AlbedoSnowDif (:) = undefined_real + noahmp%energy%state%AlbedoSoilDir (:) = undefined_real + noahmp%energy%state%AlbedoSoilDif (:) = undefined_real + noahmp%energy%state%AlbedoGrdDir (:) = undefined_real + noahmp%energy%state%AlbedoGrdDif (:) = undefined_real + noahmp%energy%state%ReflectanceVeg (:) = undefined_real + noahmp%energy%state%TransmittanceVeg (:) = undefined_real + noahmp%energy%state%AlbedoSfcDir (:) = undefined_real + noahmp%energy%state%AlbedoSfcDif (:) = undefined_real + + ! energy flux variables + noahmp%energy%flux%HeatLatentCanopy = undefined_real + noahmp%energy%flux%HeatLatentTransp = undefined_real + noahmp%energy%flux%HeatLatentGrd = undefined_real + noahmp%energy%flux%HeatPrecipAdvCanopy = undefined_real + noahmp%energy%flux%HeatPrecipAdvVegGrd = undefined_real + noahmp%energy%flux%HeatPrecipAdvBareGrd = undefined_real + noahmp%energy%flux%HeatPrecipAdvSfc = undefined_real + noahmp%energy%flux%RadPhotoActAbsSunlit = undefined_real + noahmp%energy%flux%RadPhotoActAbsShade = undefined_real + noahmp%energy%flux%RadSwAbsVeg = undefined_real + noahmp%energy%flux%RadSwAbsGrd = undefined_real + noahmp%energy%flux%RadSwAbsSfc = undefined_real + noahmp%energy%flux%RadSwReflSfc = undefined_real + noahmp%energy%flux%RadSwReflVeg = undefined_real + noahmp%energy%flux%RadSwReflGrd = undefined_real + noahmp%energy%flux%RadLwNetCanopy = undefined_real + noahmp%energy%flux%HeatSensibleCanopy = undefined_real + noahmp%energy%flux%HeatLatentCanEvap = undefined_real + noahmp%energy%flux%RadLwNetVegGrd = undefined_real + noahmp%energy%flux%HeatSensibleVegGrd = undefined_real + noahmp%energy%flux%HeatLatentVegGrd = undefined_real + noahmp%energy%flux%HeatLatentCanTransp = undefined_real + noahmp%energy%flux%HeatGroundVegGrd = undefined_real + noahmp%energy%flux%RadLwNetBareGrd = undefined_real + noahmp%energy%flux%HeatSensibleBareGrd = undefined_real + noahmp%energy%flux%HeatLatentBareGrd = undefined_real + noahmp%energy%flux%HeatGroundBareGrd = undefined_real + noahmp%energy%flux%HeatGroundTot = undefined_real + noahmp%energy%flux%HeatFromSoilBot = undefined_real + noahmp%energy%flux%RadLwNetSfc = undefined_real + noahmp%energy%flux%HeatSensibleSfc = undefined_real + noahmp%energy%flux%RadPhotoActAbsCan = undefined_real + noahmp%energy%flux%RadLwEmitSfc = undefined_real + noahmp%energy%flux%HeatCanStorageChg = undefined_real + noahmp%energy%flux%HeatGroundTotAcc = undefined_real + noahmp%energy%flux%HeatGroundTotMean = undefined_real + noahmp%energy%flux%HeatLatentIrriEvap = 0.0 + + if ( .not. allocated(noahmp%energy%flux%RadSwAbsVegDir) ) & + allocate( noahmp%energy%flux%RadSwAbsVegDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwAbsVegDif) ) & + allocate( noahmp%energy%flux%RadSwAbsVegDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDirTranGrdDir) ) & + allocate( noahmp%energy%flux%RadSwDirTranGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDirTranGrdDif) ) & + allocate( noahmp%energy%flux%RadSwDirTranGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDifTranGrdDir) ) & + allocate( noahmp%energy%flux%RadSwDifTranGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDifTranGrdDif) ) & + allocate( noahmp%energy%flux%RadSwDifTranGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflVegDir) ) & + allocate( noahmp%energy%flux%RadSwReflVegDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflVegDif) ) & + allocate( noahmp%energy%flux%RadSwReflVegDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflGrdDir) ) & + allocate( noahmp%energy%flux%RadSwReflGrdDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwReflGrdDif) ) & + allocate( noahmp%energy%flux%RadSwReflGrdDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDownDir) ) & + allocate( noahmp%energy%flux%RadSwDownDir(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwDownDif) ) & + allocate( noahmp%energy%flux%RadSwDownDif(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%flux%RadSwPenetrateGrd) ) & + allocate( noahmp%energy%flux%RadSwPenetrateGrd(-NumSnowLayerMax+1:NumSoilLayer) ) + + noahmp%energy%flux%RadSwAbsVegDir (:) = undefined_real + noahmp%energy%flux%RadSwAbsVegDif (:) = undefined_real + noahmp%energy%flux%RadSwDirTranGrdDir(:) = undefined_real + noahmp%energy%flux%RadSwDirTranGrdDif(:) = undefined_real + noahmp%energy%flux%RadSwDifTranGrdDir(:) = undefined_real + noahmp%energy%flux%RadSwDifTranGrdDif(:) = undefined_real + noahmp%energy%flux%RadSwReflVegDir (:) = undefined_real + noahmp%energy%flux%RadSwReflVegDif (:) = undefined_real + noahmp%energy%flux%RadSwReflGrdDir (:) = undefined_real + noahmp%energy%flux%RadSwReflGrdDif (:) = undefined_real + noahmp%energy%flux%RadSwDownDir (:) = undefined_real + noahmp%energy%flux%RadSwDownDif (:) = undefined_real + noahmp%energy%flux%RadSwPenetrateGrd (:) = undefined_real + + ! energy parameter variables + noahmp%energy%param%TreeCrownRadius = undefined_real + noahmp%energy%param%HeightCanopyTop = undefined_real + noahmp%energy%param%HeightCanopyBot = undefined_real + noahmp%energy%param%RoughLenMomVeg = undefined_real + noahmp%energy%param%TreeDensity = undefined_real + noahmp%energy%param%CanopyOrientIndex = undefined_real + noahmp%energy%param%UpscatterCoeffSnowDir = undefined_real + noahmp%energy%param%UpscatterCoeffSnowDif = undefined_real + noahmp%energy%param%SoilHeatCapacity = undefined_real + noahmp%energy%param%SnowAgeFacBats = undefined_real + noahmp%energy%param%SnowGrowVapFacBats = undefined_real + noahmp%energy%param%SnowSootFacBats = undefined_real + noahmp%energy%param%SnowGrowFrzFacBats = undefined_real + noahmp%energy%param%SolarZenithAdjBats = undefined_real + noahmp%energy%param%FreshSnoAlbVisBats = undefined_real + noahmp%energy%param%FreshSnoAlbNirBats = undefined_real + noahmp%energy%param%SnoAgeFacDifVisBats = undefined_real + noahmp%energy%param%SnoAgeFacDifNirBats = undefined_real + noahmp%energy%param%SzaFacDirVisBats = undefined_real + noahmp%energy%param%SzaFacDirNirBats = undefined_real + noahmp%energy%param%SnowAlbRefClass = undefined_real + noahmp%energy%param%SnowAgeFacClass = undefined_real + noahmp%energy%param%SnowAlbFreshClass = undefined_real + noahmp%energy%param%ConductanceLeafMin = undefined_real + noahmp%energy%param%Co2MmConst25C = undefined_real + noahmp%energy%param%O2MmConst25C = undefined_real + noahmp%energy%param%Co2MmConstQ10 = undefined_real + noahmp%energy%param%O2MmConstQ10 = undefined_real + noahmp%energy%param%RadiationStressFac = undefined_real + noahmp%energy%param%ResistanceStomataMin = undefined_real + noahmp%energy%param%ResistanceStomataMax = undefined_real + noahmp%energy%param%AirTempOptimTransp = undefined_real + noahmp%energy%param%VaporPresDeficitFac = undefined_real + noahmp%energy%param%LeafDimLength = undefined_real + noahmp%energy%param%ZilitinkevichCoeff = undefined_real + noahmp%energy%param%EmissivitySnow = undefined_real + noahmp%energy%param%CanopyWindExtFac = undefined_real + noahmp%energy%param%RoughLenMomSnow = undefined_real + noahmp%energy%param%RoughLenMomSoil = undefined_real + noahmp%energy%param%RoughLenMomLake = undefined_real + noahmp%energy%param%EmissivityIceSfc = undefined_real + noahmp%energy%param%ResistanceSoilExp = undefined_real + noahmp%energy%param%ResistanceSnowSfc = undefined_real + noahmp%energy%param%VegFracAnnMax = undefined_real + noahmp%energy%param%VegFracGreen = undefined_real + noahmp%energy%param%HeatCapacCanFac = undefined_real + + if ( .not. allocated(noahmp%energy%param%LeafAreaIndexMon) ) & + allocate( noahmp%energy%param%LeafAreaIndexMon(1:12) ) + if ( .not. allocated(noahmp%energy%param%StemAreaIndexMon) ) & + allocate( noahmp%energy%param%StemAreaIndexMon(1:12) ) + if ( .not. allocated(noahmp%energy%param%SoilQuartzFrac) ) & + allocate( noahmp%energy%param%SoilQuartzFrac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%energy%param%AlbedoSoilSat) ) & + allocate( noahmp%energy%param%AlbedoSoilSat(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%AlbedoSoilDry) ) & + allocate( noahmp%energy%param%AlbedoSoilDry(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%AlbedoLakeFrz) ) & + allocate( noahmp%energy%param%AlbedoLakeFrz(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%ScatterCoeffSnow) ) & + allocate( noahmp%energy%param%ScatterCoeffSnow(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%ReflectanceLeaf) ) & + allocate( noahmp%energy%param%ReflectanceLeaf(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%ReflectanceStem) ) & + allocate( noahmp%energy%param%ReflectanceStem(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%TransmittanceLeaf) ) & + allocate( noahmp%energy%param%TransmittanceLeaf(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%TransmittanceStem) ) & + allocate( noahmp%energy%param%TransmittanceStem(1:NumSwRadBand) ) + if ( .not. allocated(noahmp%energy%param%EmissivitySoilLake) ) & + allocate( noahmp%energy%param%EmissivitySoilLake(1:2) ) + if ( .not. allocated(noahmp%energy%param%AlbedoLandIce) ) & + allocate( noahmp%energy%param%AlbedoLandIce(1:NumSwRadBand) ) + + noahmp%energy%param%LeafAreaIndexMon (:) = undefined_real + noahmp%energy%param%StemAreaIndexMon (:) = undefined_real + noahmp%energy%param%SoilQuartzFrac (:) = undefined_real + noahmp%energy%param%AlbedoSoilSat (:) = undefined_real + noahmp%energy%param%AlbedoSoilDry (:) = undefined_real + noahmp%energy%param%AlbedoLakeFrz (:) = undefined_real + noahmp%energy%param%ScatterCoeffSnow (:) = undefined_real + noahmp%energy%param%ReflectanceLeaf (:) = undefined_real + noahmp%energy%param%ReflectanceStem (:) = undefined_real + noahmp%energy%param%TransmittanceLeaf (:) = undefined_real + noahmp%energy%param%TransmittanceStem (:) = undefined_real + noahmp%energy%param%EmissivitySoilLake(:) = undefined_real + noahmp%energy%param%AlbedoLandIce (:) = undefined_real + + end associate + + end subroutine EnergyVarInitDefault + +end module EnergyVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarType.F90 new file mode 100644 index 0000000000..0805d30344 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/EnergyVarType.F90 @@ -0,0 +1,309 @@ +module EnergyVarType + +!!! Define column (1-D) Noah-MP Energy variables +!!! Energy variable initialization is done in EnergyVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "flux" sub-type of energy (energy%flux%variable) + type :: flux_type + + real(kind=kind_noahmp) :: HeatLatentCanopy ! canopy latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentTransp ! latent heat flux from transpiration [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentGrd ! total ground latent heat [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentIrriEvap ! latent heating due to sprinkler irrigation evaporation [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvCanopy ! precipitation advected heat - canopy net [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvVegGrd ! precipitation advected heat - vegetated ground net [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvBareGrd ! precipitation advected heat - bare ground net [W/m2] + real(kind=kind_noahmp) :: HeatPrecipAdvSfc ! precipitation advected heat - total [W/m2] + real(kind=kind_noahmp) :: HeatSensibleCanopy ! canopy sensible heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentCanEvap ! canopy evaporation heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatSensibleVegGrd ! vegetated ground sensible heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatSensibleSfc ! total sensible heat [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentVegGrd ! vegetated ground latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentCanTransp ! canopy transpiration latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatGroundVegGrd ! vegetated ground heat flux [W/m2] (+ to soil/snow) + real(kind=kind_noahmp) :: HeatSensibleBareGrd ! bare ground sensible heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatLatentBareGrd ! bare ground latent heat flux [W/m2] (+ to atm) + real(kind=kind_noahmp) :: HeatGroundBareGrd ! bare ground heat flux [W/m2] (+ to soil/snow) + real(kind=kind_noahmp) :: HeatGroundTot ! total ground heat flux [W/m2] (+ to soil/snow) + real(kind=kind_noahmp) :: HeatGroundTotMean ! total ground heat flux [W/m2] averaged over soil timestep + real(kind=kind_noahmp) :: HeatFromSoilBot ! energy influx from soil bottom [W/m2] + real(kind=kind_noahmp) :: HeatCanStorageChg ! canopy heat storage change [W/m2] + real(kind=kind_noahmp) :: HeatGroundTotAcc ! accumulated total ground heat flux per soil timestep [W/m2 * dt_soil/dt_main] (+ to soil/snow) + real(kind=kind_noahmp) :: RadPhotoActAbsSunlit ! absorbed photosyn. active radiation for sunlit leaves [W/m2] + real(kind=kind_noahmp) :: RadPhotoActAbsShade ! absorbed photosyn. active radiation for shaded leaves [W/m2] + real(kind=kind_noahmp) :: RadSwAbsVeg ! solar radiation absorbed by vegetation [W/m2] + real(kind=kind_noahmp) :: RadSwAbsGrd ! solar radiation absorbed by ground [W/m2] + real(kind=kind_noahmp) :: RadSwAbsSfc ! total absorbed solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflSfc ! total reflected solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflVeg ! reflected solar radiation by vegetation [W/m2] + real(kind=kind_noahmp) :: RadSwReflGrd ! reflected solar radiation by ground [W/m2] + real(kind=kind_noahmp) :: RadLwNetCanopy ! canopy net longwave radiation [W/m2] (+ to atm) + real(kind=kind_noahmp) :: RadLwNetSfc ! total net longwave radiation [W/m2] (+ to atm) + real(kind=kind_noahmp) :: RadPhotoActAbsCan ! total photosyn. active energy [W/m2] absorbed by canopy + real(kind=kind_noahmp) :: RadLwEmitSfc ! emitted outgoing longwave radiation [W/m2] + real(kind=kind_noahmp) :: RadLwNetVegGrd ! vegetated ground net longwave radiation [W/m2] (+ to atm) + real(kind=kind_noahmp) :: RadLwNetBareGrd ! bare ground net longwave rad [W/m2] (+ to atm) + + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsVegDir ! solar flux absorbed by veg per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsVegDif ! solar flux absorbed by veg per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDirTranGrdDir ! transmitted direct flux below veg per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDirTranGrdDif ! transmitted direct flux below veg per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDifTranGrdDir ! transmitted diffuse flux below veg per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDifTranGrdDif ! transmitted diffuse flux below veg per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflVegDir ! solar flux reflected by veg layer per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflVegDif ! solar flux reflected by veg layer per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflGrdDir ! solar flux reflected by ground per unit direct flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwReflGrdDif ! solar flux reflected by ground per unit diffuse flux + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDownDir ! incoming direct solar radiation [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwDownDif ! incoming diffuse solar radiation [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwPenetrateGrd ! light penetrating through soil/snow water [W/m2] + + end type flux_type + + +!=== define "state" sub-type of energy (energy%state%variable) + type :: state_type + + logical :: FlagFrozenCanopy ! frozen canopy flag used to define latent heat pathway + logical :: FlagFrozenGround ! frozen ground flag used to define latent heat pathway + real(kind=kind_noahmp) :: LeafAreaIndEff ! effective leaf area index, after burying by snow + real(kind=kind_noahmp) :: StemAreaIndEff ! effective stem area index, after burying by snow + real(kind=kind_noahmp) :: LeafAreaIndex ! leaf area index + real(kind=kind_noahmp) :: StemAreaIndex ! stem area index + real(kind=kind_noahmp) :: VegAreaIndEff ! one-sided leaf+stem area index [m2/m2], after burying by snow + real(kind=kind_noahmp) :: VegFrac ! greeness vegetation fraction + real(kind=kind_noahmp) :: TemperatureGrd ! ground temperature [K] + real(kind=kind_noahmp) :: TemperatureCanopy ! vegetation/canopy temperature [K] + real(kind=kind_noahmp) :: TemperatureSfc ! surface temperature [K] + real(kind=kind_noahmp) :: TemperatureRootZone ! root-zone averaged temperature [K] + real(kind=kind_noahmp) :: PressureVaporRefHeight ! vapor pressure air [Pa] + real(kind=kind_noahmp) :: SnowAgeFac ! snow age factor + real(kind=kind_noahmp) :: SnowAgeNondim ! non-dimensional snow age + real(kind=kind_noahmp) :: AlbedoSnowPrev ! snow albedo at last time step + real(kind=kind_noahmp) :: VegAreaProjDir ! projected leaf+stem area in solar direction + real(kind=kind_noahmp) :: GapBtwCanopy ! between canopy gap fraction for beam + real(kind=kind_noahmp) :: GapInCanopy ! within canopy gap fraction for beam + real(kind=kind_noahmp) :: GapCanopyDif ! gap fraction for diffue light + real(kind=kind_noahmp) :: GapCanopyDir ! total gap fraction for beam (<=1-shafac) + real(kind=kind_noahmp) :: CanopySunlitFrac ! sunlit fraction of canopy + real(kind=kind_noahmp) :: CanopyShadeFrac ! shaded fraction of canopy + real(kind=kind_noahmp) :: LeafAreaIndSunlit ! sunlit leaf area + real(kind=kind_noahmp) :: LeafAreaIndShade ! shaded leaf area + real(kind=kind_noahmp) :: VapPresSatCanopy ! canopy saturation vapor pressure at veg temperature [Pa] + real(kind=kind_noahmp) :: VapPresSatGrdVeg ! below-canopy saturation vapor pressure at ground temperature [Pa] + real(kind=kind_noahmp) :: VapPresSatGrdBare ! bare ground saturation vapor pressure at ground temperature [Pa] + real(kind=kind_noahmp) :: VapPresSatCanTempD ! canopy saturation vapor pressure derivative with temperature at veg temp. [Pa/K] + real(kind=kind_noahmp) :: VapPresSatGrdVegTempD ! below-canopy saturation vapor pressure derivative with temperature at ground temp. [Pa/K] + real(kind=kind_noahmp) :: VapPresSatGrdBareTempD ! bare ground saturation vapor pressure derivative with temperature at ground temp. [Pa/K] + real(kind=kind_noahmp) :: PressureVaporCanAir ! canopy air vapor pressure [Pa] + real(kind=kind_noahmp) :: PressureAtmosCO2 ! atmospheric co2 partial pressure [Pa] + real(kind=kind_noahmp) :: PressureAtmosO2 ! atmospheric o2 partial pressure [Pa] + real(kind=kind_noahmp) :: ResistanceStomataSunlit ! sunlit leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: ResistanceStomataShade ! shaded leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: DensityAirRefHeight ! density air [kg/m3] at reference height + real(kind=kind_noahmp) :: TemperatureCanopyAir ! canopy air temperature [K] + real(kind=kind_noahmp) :: ZeroPlaneDispSfc ! surface zero plane displacement [m] + real(kind=kind_noahmp) :: ZeroPlaneDispGrd ! ground zero plane displacement [m] + real(kind=kind_noahmp) :: RoughLenMomGrd ! roughness length, momentum, ground [m] + real(kind=kind_noahmp) :: RoughLenMomSfc ! roughness length, momentum, surface [m] + real(kind=kind_noahmp) :: RoughLenShCanopy ! roughness length, sensible heat, canopy [m] + real(kind=kind_noahmp) :: RoughLenShVegGrd ! roughness length, sensible heat, ground, below canopy [m] + real(kind=kind_noahmp) :: RoughLenShBareGrd ! roughness length, sensible heat, bare ground [m] + real(kind=kind_noahmp) :: CanopyHeight ! canopy height [m] + real(kind=kind_noahmp) :: WindSpdCanopyTop ! wind speed at top of canopy [m/s] + real(kind=kind_noahmp) :: FrictionVelVeg ! friction velocity [m/s], vegetated + real(kind=kind_noahmp) :: FrictionVelBare ! friction velocity [m/s], bare ground + real(kind=kind_noahmp) :: WindExtCoeffCanopy ! canopy wind extinction coefficient + real(kind=kind_noahmp) :: MoStabParaUndCan ! M-O stability parameter ground, below canopy + real(kind=kind_noahmp) :: MoStabParaAbvCan ! M-O stability parameter (z/L), above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoStabParaBare ! M-O stability parameter (z/L), above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabParaVeg2m ! M-O stability parameter (2/L), 2m, vegetated + real(kind=kind_noahmp) :: MoStabParaBare2m ! M-O stability parameter (2/L), 2m, bare ground + real(kind=kind_noahmp) :: MoLengthUndCan ! M-O length [m], ground, below canopy + real(kind=kind_noahmp) :: MoLengthAbvCan ! M-O length [m], above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoLengthBare ! M-O length [m], above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabCorrShUndCan ! M-O stability correction ground, below canopy + real(kind=kind_noahmp) :: MoStabCorrMomAbvCan ! M-O momentum stability correction, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoStabCorrShAbvCan ! M-O sensible heat stability correction, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: MoStabCorrMomVeg2m ! M-O momentum stability correction, 2m, vegetated + real(kind=kind_noahmp) :: MoStabCorrShVeg2m ! M-O sensible heat stability correction, 2m, vegetated + real(kind=kind_noahmp) :: MoStabCorrShBare ! M-O sensible heat stability correction, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabCorrMomBare ! M-O momentum stability correction, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: MoStabCorrMomBare2m ! M-O momentum stability correction, 2m, bare ground + real(kind=kind_noahmp) :: MoStabCorrShBare2m ! M-O sensible heat stability correction, 2m, bare ground + real(kind=kind_noahmp) :: ExchCoeffMomSfc ! exchange coefficient [m/s] for momentum, surface, grid mean + real(kind=kind_noahmp) :: ExchCoeffMomAbvCan ! exchange coefficient [m/s] for momentum, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: ExchCoeffMomBare ! exchange coefficient [m/s] for momentum, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: ExchCoeffShSfc ! exchange coefficient [m/s] for sensible heat, surface, grid mean + real(kind=kind_noahmp) :: ExchCoeffShAbvCan ! exchange coefficient [m/s] for sensible heat, above ZeroPlaneDisp, vegetated + real(kind=kind_noahmp) :: ExchCoeffShBare ! exchange coefficient [m/s] for sensible heat, above ZeroPlaneDisp, bare ground + real(kind=kind_noahmp) :: ExchCoeffSh2mVegMo ! exchange coefficient [m/s] for sensible heat, 2m, vegetated (M-O) + real(kind=kind_noahmp) :: ExchCoeffSh2mBareMo ! exchange coefficient [m/s] for sensible heat, 2m, bare ground (M-O) + real(kind=kind_noahmp) :: ExchCoeffSh2mVeg ! exchange coefficient [m/s] for sensible heat, 2m, vegetated (diagnostic) + real(kind=kind_noahmp) :: ExchCoeffLhAbvCan ! exchange coefficient [m/s] for latent heat, canopy air to ref height + real(kind=kind_noahmp) :: ExchCoeffLhTransp ! exchange coefficient [m/s] for transpiration, leaf to canopy air + real(kind=kind_noahmp) :: ExchCoeffLhEvap ! exchange coefficient [m/s] for leaf evaporation, leaf to canopy air + real(kind=kind_noahmp) :: ExchCoeffLhUndCan ! exchange coefficient [m/s] for latent heat, ground to canopy air + real(kind=kind_noahmp) :: ResistanceMomUndCan ! aerodynamic resistance [s/m] for momentum, ground, below canopy + real(kind=kind_noahmp) :: ResistanceShUndCan ! aerodynamic resistance [s/m] for sensible heat, ground, below canopy + real(kind=kind_noahmp) :: ResistanceLhUndCan ! aerodynamic resistance [s/m] for water vapor, ground, below canopy + real(kind=kind_noahmp) :: ResistanceMomAbvCan ! aerodynamic resistance [s/m] for momentum, above canopy + real(kind=kind_noahmp) :: ResistanceShAbvCan ! aerodynamic resistance [s/m] for sensible heat, above canopy + real(kind=kind_noahmp) :: ResistanceLhAbvCan ! aerodynamic resistance [s/m] for water vapor, above canopy + real(kind=kind_noahmp) :: ResistanceMomBareGrd ! aerodynamic resistance [s/m] for momentum, bare ground + real(kind=kind_noahmp) :: ResistanceShBareGrd ! aerodynamic resistance [s/m] for sensible heat, bare ground + real(kind=kind_noahmp) :: ResistanceLhBareGrd ! aerodynamic resistance [s/m] for water vapor, bare ground + real(kind=kind_noahmp) :: ResistanceLeafBoundary ! bulk leaf boundary layer resistance [s/m] + real(kind=kind_noahmp) :: TemperaturePotRefHeight ! potential temp at reference height [K] + real(kind=kind_noahmp) :: WindSpdRefHeight ! wind speed [m/s] at reference height + real(kind=kind_noahmp) :: FrictionVelVertVeg ! friction velocity in vertical direction [m/s], vegetated (only for Chen97) + real(kind=kind_noahmp) :: FrictionVelVertBare ! friction velocity in vertical direction [m/s], bare ground (only for Chen97) + real(kind=kind_noahmp) :: EmissivityVeg ! vegetation emissivity + real(kind=kind_noahmp) :: EmissivityGrd ! ground emissivity + real(kind=kind_noahmp) :: ResistanceGrdEvap ! ground surface resistance [s/m] to evaporation/sublimation + real(kind=kind_noahmp) :: PsychConstCanopy ! psychrometric constant [Pa/K], canopy + real(kind=kind_noahmp) :: LatHeatVapCanopy ! latent heat of vaporization/subli [J/kg], canopy + real(kind=kind_noahmp) :: PsychConstGrd ! psychrometric constant [Pa/K], ground + real(kind=kind_noahmp) :: LatHeatVapGrd ! latent heat of vaporization/subli [J/kg], ground + real(kind=kind_noahmp) :: RelHumidityGrd ! raltive humidity in surface soil/snow air space (-) + real(kind=kind_noahmp) :: SpecHumiditySfc ! specific humidity at surface (bare or vegetated or urban) + real(kind=kind_noahmp) :: SpecHumiditySfcMean ! specific humidity at surface grid mean + real(kind=kind_noahmp) :: SpecHumidity2mVeg ! specific humidity at 2m vegetated + real(kind=kind_noahmp) :: SpecHumidity2mBare ! specific humidity at 2m bare ground + real(kind=kind_noahmp) :: SpecHumidity2m ! specific humidity at 2m grid mean + real(kind=kind_noahmp) :: TemperatureGrdVeg ! vegetated ground (below-canopy) temperature [K] + real(kind=kind_noahmp) :: TemperatureGrdBare ! bare ground temperature [K] + real(kind=kind_noahmp) :: WindStressEwVeg ! wind stress [N/m2]: east-west above canopy + real(kind=kind_noahmp) :: WindStressNsVeg ! wind stress [N/m2]: north-south above canopy + real(kind=kind_noahmp) :: WindStressEwBare ! wind stress [N/m2]: east-west bare ground + real(kind=kind_noahmp) :: WindStressNsBare ! wind stress [N/m2]: north-south bare ground + real(kind=kind_noahmp) :: WindStressEwSfc ! wind stress [N/m2]: east-west grid mean + real(kind=kind_noahmp) :: WindStressNsSfc ! wind stress [N/m2]: north-south grid mean + real(kind=kind_noahmp) :: TemperatureAir2mVeg ! 2 m height air temperature [K], vegetated + real(kind=kind_noahmp) :: TemperatureAir2mBare ! 2 m height air temperature [K], bare ground + real(kind=kind_noahmp) :: TemperatureAir2m ! 2 m height air temperature [K], grid mean + real(kind=kind_noahmp) :: ExchCoeffShLeaf ! leaf sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffShUndCan ! under canopy sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffSh2mBare ! bare ground 2-m sensible heat exchange coefficient [m/s] (diagnostic) + real(kind=kind_noahmp) :: RefHeightAboveGrd ! reference height [m] above ground + real(kind=kind_noahmp) :: CanopyFracSnowBury ! fraction of canopy buried by snow + real(kind=kind_noahmp) :: DepthSoilTempBotToSno ! depth of soil temperature lower boundary condition from snow surface [m] + real(kind=kind_noahmp) :: RoughLenMomSfcToAtm ! roughness length, momentum, surface, sent to coupled atmos model + real(kind=kind_noahmp) :: TemperatureRadSfc ! radiative temperature [K] + real(kind=kind_noahmp) :: EmissivitySfc ! surface emissivity + real(kind=kind_noahmp) :: AlbedoSfc ! total surface albedo + real(kind=kind_noahmp) :: EnergyBalanceError ! error in surface energy balance [W/m2] + real(kind=kind_noahmp) :: RadSwBalanceError ! error in shortwave radiation balance [W/m2] + + real(kind=kind_noahmp), allocatable, dimension(:) :: TemperatureSoilSnow ! snow and soil layer temperature [K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacVolSnow ! snow layer volumetric specific heat capacity [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductSnow ! snow layer thermal conductivity [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacVolSoil ! soil layer volumetric specific heat capacity [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductSoil ! soil layer thermal conductivity [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacGlaIce ! glacier ice layer volumetric specific heat [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductGlaIce ! glacier ice thermal conductivity [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThermConductSoilSnow ! thermal conductivity for all soil and snow layers [W/m/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacSoilSnow ! heat capacity for all snow and soil layers [J/m3/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: PhaseChgFacSoilSnow ! energy factor for soil and snow phase change + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSnowDir ! snow albedo for direct(1=vis, 2=nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSnowDif ! snow albedo for diffuse(1=vis, 2=nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilDir ! soil albedo (direct) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilDif ! soil albedo (diffuse) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoGrdDir ! ground albedo (direct beam: vis, nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoGrdDif ! ground albedo (diffuse: vis, nir) + real(kind=kind_noahmp), allocatable, dimension(:) :: ReflectanceVeg ! leaf/stem reflectance weighted by LeafAreaIndex and StemAreaIndex + real(kind=kind_noahmp), allocatable, dimension(:) :: TransmittanceVeg ! leaf/stem transmittance weighted by LeafAreaIndex and StemAreaIndex + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSfcDir ! surface albedo (direct) + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSfcDif ! surface albedo (diffuse) + + end type state_type + + +!=== define "parameter" sub-type of energy (energy%param%variable) + type :: parameter_type + + real(kind=kind_noahmp) :: TreeCrownRadius ! tree crown radius [m] + real(kind=kind_noahmp) :: HeightCanopyTop ! height of canopy top [m] + real(kind=kind_noahmp) :: HeightCanopyBot ! height of canopy bottom [m] + real(kind=kind_noahmp) :: RoughLenMomVeg ! momentum roughness length [m] vegetated + real(kind=kind_noahmp) :: TreeDensity ! tree density [no. of trunks per m2] + real(kind=kind_noahmp) :: CanopyOrientIndex ! leaf/stem orientation index + real(kind=kind_noahmp) :: UpscatterCoeffSnowDir ! Upscattering parameters for snow for direct radiation + real(kind=kind_noahmp) :: UpscatterCoeffSnowDif ! Upscattering parameters for snow for diffuse radiation + real(kind=kind_noahmp) :: SoilHeatCapacity ! volumetric soil heat capacity [j/m3/K] + real(kind=kind_noahmp) :: SnowAgeFacBats ! snow aging parameter for BATS snow albedo + real(kind=kind_noahmp) :: SnowGrowVapFacBats ! vapor diffusion snow growth factor for BATS snow albedo + real(kind=kind_noahmp) :: SnowSootFacBats ! dirt and soot effect factor for BATS snow albedo + real(kind=kind_noahmp) :: SnowGrowFrzFacBats ! extra snow growth factor near freezing for BATS snow albedo + real(kind=kind_noahmp) :: SolarZenithAdjBats ! zenith angle snow albedo adjustment + real(kind=kind_noahmp) :: FreshSnoAlbVisBats ! new snow visible albedo for BATS + real(kind=kind_noahmp) :: FreshSnoAlbNirBats ! new snow NIR albedo for BATS + real(kind=kind_noahmp) :: SnoAgeFacDifVisBats ! age factor for diffuse visible snow albedo for BATS + real(kind=kind_noahmp) :: SnoAgeFacDifNirBats ! age factor for diffuse NIR snow albedo for BATS + real(kind=kind_noahmp) :: SzaFacDirVisBats ! cosz factor for direct visible snow albedo for BATS + real(kind=kind_noahmp) :: SzaFacDirNirBats ! cosz factor for direct NIR snow albedo for BATS + real(kind=kind_noahmp) :: SnowAlbRefClass ! reference snow albedo in CLASS scheme + real(kind=kind_noahmp) :: SnowAgeFacClass ! snow aging e-folding time [s] in CLASS albedo scheme + real(kind=kind_noahmp) :: SnowAlbFreshClass ! fresh snow albedo in CLASS albedo scheme + real(kind=kind_noahmp) :: ConductanceLeafMin ! minimum leaf conductance [umol/m2/s] + real(kind=kind_noahmp) :: Co2MmConst25C ! co2 michaelis-menten constant at 25c [Pa] + real(kind=kind_noahmp) :: O2MmConst25C ! o2 michaelis-menten constant at 25c [Pa] + real(kind=kind_noahmp) :: Co2MmConstQ10 ! change in co2 Michaelis-Menten constant for every 10-deg C temperature change + real(kind=kind_noahmp) :: O2MmConstQ10 ! change in o2 michaelis-menten constant for every 10-deg C temperature change + real(kind=kind_noahmp) :: RadiationStressFac ! Parameter used in radiation stress function in Jarvis scheme + real(kind=kind_noahmp) :: ResistanceStomataMin ! Minimum stomatal resistance [s/m] in Jarvis scheme + real(kind=kind_noahmp) :: ResistanceStomataMax ! Maximal stomatal resistance [s/m] in Jarvis scheme + real(kind=kind_noahmp) :: AirTempOptimTransp ! Optimum transpiration air temperature [K] in Jarvis scheme + real(kind=kind_noahmp) :: VaporPresDeficitFac ! Parameter used in vapor pressure deficit function in Jarvis scheme + real(kind=kind_noahmp) :: LeafDimLength ! characteristic leaf dimension [m] + real(kind=kind_noahmp) :: ZilitinkevichCoeff ! Zilitinkevich coefficient for heat exchange coefficient calculation + real(kind=kind_noahmp) :: EmissivitySnow ! snow emissivity + real(kind=kind_noahmp) :: CanopyWindExtFac ! empirical canopy wind extinction parameter + real(kind=kind_noahmp) :: RoughLenMomSnow ! snow surface roughness length [m] + real(kind=kind_noahmp) :: RoughLenMomSoil ! Bare-soil roughness length [m] + real(kind=kind_noahmp) :: RoughLenMomLake ! lake surface roughness length [m] + real(kind=kind_noahmp) :: EmissivityIceSfc ! ice surface emissivity + real(kind=kind_noahmp) :: ResistanceSoilExp ! exponent in the shape parameter for soil resistance option 1 + real(kind=kind_noahmp) :: ResistanceSnowSfc ! surface resistance for snow [s/m] + real(kind=kind_noahmp) :: VegFracGreen ! green vegetation fraction + real(kind=kind_noahmp) :: VegFracAnnMax ! annual maximum vegetation fraction + real(kind=kind_noahmp) :: HeatCapacCanFac ! canopy biomass heat capacity parameter [m] + + real(kind=kind_noahmp), allocatable, dimension(:) :: LeafAreaIndexMon ! monthly leaf area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:) :: StemAreaIndexMon ! monthly stem area index, one-sided + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilQuartzFrac ! soil quartz content + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilSat ! saturated soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoSoilDry ! dry soil albedos: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoLakeFrz ! albedo frozen lakes: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: ScatterCoeffSnow ! Scattering coefficient for snow + real(kind=kind_noahmp), allocatable, dimension(:) :: ReflectanceLeaf ! leaf reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: ReflectanceStem ! stem reflectance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: TransmittanceLeaf ! leaf transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: TransmittanceStem ! stem transmittance: 1=vis, 2=nir + real(kind=kind_noahmp), allocatable, dimension(:) :: EmissivitySoilLake ! emissivity soil surface: 1=soil, 2=lake + real(kind=kind_noahmp), allocatable, dimension(:) :: AlbedoLandIce ! land/glacier ice albedo: 1=vis, 2=nir + + end type parameter_type + + +!=== define energy type that includes 3 subtypes (flux,state,parameter) + type, public :: energy_type + + type(flux_type) :: flux + type(state_type) :: state + type(parameter_type) :: param + + end type energy_type + +end module EnergyVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarInitMod.F90 new file mode 100644 index 0000000000..b69c589e0a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarInitMod.F90 @@ -0,0 +1,43 @@ +module ForcingVarInitMod + +!!! Initialize column (1-D) Noah-MP forcing variables +!!! Forcing variables should be first defined in ForcingVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine ForcingVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + noahmp%forcing%SpecHumidityRefHeight = undefined_real + noahmp%forcing%TemperatureAirRefHeight = undefined_real + noahmp%forcing%WindEastwardRefHeight = undefined_real + noahmp%forcing%WindNorthwardRefHeight = undefined_real + noahmp%forcing%RadLwDownRefHeight = undefined_real + noahmp%forcing%RadSwDownRefHeight = undefined_real + noahmp%forcing%PrecipConvRefHeight = undefined_real + noahmp%forcing%PrecipNonConvRefHeight = undefined_real + noahmp%forcing%PrecipShConvRefHeight = undefined_real + noahmp%forcing%PrecipSnowRefHeight = undefined_real + noahmp%forcing%PrecipGraupelRefHeight = undefined_real + noahmp%forcing%PrecipHailRefHeight = undefined_real + noahmp%forcing%PressureAirSurface = undefined_real + noahmp%forcing%PressureAirRefHeight = undefined_real + noahmp%forcing%TemperatureSoilBottom = undefined_real + + end subroutine ForcingVarInitDefault + +end module ForcingVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarType.F90 new file mode 100644 index 0000000000..a88aa316b1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ForcingVarType.F90 @@ -0,0 +1,37 @@ +module ForcingVarType + +!!! Define column (1-D) Noah-MP forcing variables +!!! Forcing variable initialization is done in ForcingVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + + type, public :: forcing_type + + real(kind=kind_noahmp) :: SpecHumidityRefHeight ! Specific humidity [kg water vapor / kg moist air] forcing at reference height + real(kind=kind_noahmp) :: TemperatureAirRefHeight ! Air temperature [K] forcing at reference height + real(kind=kind_noahmp) :: WindEastwardRefHeight ! wind speed [m/s] in eastward dir at reference height + real(kind=kind_noahmp) :: WindNorthwardRefHeight ! wind speed [m/s] in northward dir at reference height + real(kind=kind_noahmp) :: RadSwDownRefHeight ! downward shortwave radiation [W/m2] at reference height + real(kind=kind_noahmp) :: RadLwDownRefHeight ! downward longwave radiation [W/m2] at reference height + real(kind=kind_noahmp) :: PressureAirRefHeight ! air pressure [Pa] at reference height + real(kind=kind_noahmp) :: PressureAirSurface ! air pressure [Pa] at surface-atmosphere interface (lowest atmos model boundary) + real(kind=kind_noahmp) :: PrecipConvRefHeight ! convective precipitation rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipNonConvRefHeight ! non-convective precipitation rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipShConvRefHeight ! shallow convective precipitation rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipSnowRefHeight ! snowfall rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipGraupelRefHeight ! graupel rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipHailRefHeight ! hail rate [mm/s] at reference height + real(kind=kind_noahmp) :: TemperatureSoilBottom ! bottom boundary condition for soil temperature [K] + + end type forcing_type + +end module ForcingVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitGlacierMod.F90 new file mode 100644 index 0000000000..278c8eeda8 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitGlacierMod.F90 @@ -0,0 +1,50 @@ +module GeneralInitGlacierMod + +!!! General initialization for glacier variables + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GeneralInitGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_GLACIER) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer & ! out, thickness of snow/soil layers [m] + ) +! ---------------------------------------------------------------------- + + ! initialize snow/soil layer thickness + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + ThicknessSnowSoilLayer(LoopInd) = - DepthSnowSoilLayer(LoopInd) + else + ThicknessSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + endif + enddo + + end associate + + end subroutine GeneralInitGlacier + +end module GeneralInitGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitMod.F90 new file mode 100644 index 0000000000..551e0176d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GeneralInitMod.F90 @@ -0,0 +1,61 @@ +module GeneralInitMod + +!!! General initialization for variables + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GeneralInit(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_SFLX) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! out, thickness of snow/soil layers [m] + TemperatureRootZone => noahmp%energy%state%TemperatureRootZone & ! out, root-zone averaged temperature [K] + ) +! ---------------------------------------------------------------------- + + ! initialize snow/soil layer thickness + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == NumSnowLayerNeg+1 ) then + ThicknessSnowSoilLayer(LoopInd) = - DepthSnowSoilLayer(LoopInd) + else + ThicknessSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + endif + enddo + + ! initialize root-zone soil temperature + TemperatureRootZone = 0.0 + do LoopInd = 1, NumSoilLayerRoot + TemperatureRootZone = TemperatureRootZone + & + TemperatureSoilSnow(LoopInd) * ThicknessSnowSoilLayer(LoopInd) / (-DepthSoilLayer(NumSoilLayerRoot)) + enddo + + end associate + + end subroutine GeneralInit + +end module GeneralInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierIceThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierIceThermalPropertyMod.F90 new file mode 100644 index 0000000000..27f9ca14ba --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierIceThermalPropertyMod.F90 @@ -0,0 +1,51 @@ +module GlacierIceThermalPropertyMod + +!!! Compute glacier ice thermal conductivity based on Noah scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GlacierIceThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: none (embedded in ENERGY_GLACIER) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd1, LoopInd2 ! loop index + real(kind=kind_noahmp) :: DepthIceLayerMid ! mid-point ice layer depth + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + HeatCapacGlaIce => noahmp%energy%state%HeatCapacGlaIce ,& ! out, glacier ice layer volumetric specific heat [J/m3/K] + ThermConductGlaIce => noahmp%energy%state%ThermConductGlaIce & ! out, glacier ice layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + do LoopInd1 = 1, NumSoilLayer + DepthIceLayerMid = 0.5 * ThicknessSnowSoilLayer(LoopInd1) + do LoopInd2 = 1, LoopInd1-1 + DepthIceLayerMid = DepthIceLayerMid + ThicknessSnowSoilLayer(LoopInd2) + enddo + HeatCapacGlaIce(LoopInd1) = 1.0e6 * (0.8194 + 0.1309 * DepthIceLayerMid) + ThermConductGlaIce(LoopInd1) = 0.32333 + (0.10073 * DepthIceLayerMid) + enddo + + end associate + + end subroutine GlacierIceThermalProperty + +end module GlacierIceThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierPhaseChangeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierPhaseChangeMod.F90 new file mode 100644 index 0000000000..3ce21f71c4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierPhaseChangeMod.F90 @@ -0,0 +1,440 @@ +module GlacierPhaseChangeMod + +!!! Compute the phase change (melting/freezing) of snow and glacier ice + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GlacierPhaseChange(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: PHASECHANGE_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: LoopInd1, LoopInd2 ! loop index + real(kind=kind_noahmp) :: SnowWaterPrev ! old/previous snow water equivalent [kg/m2] + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of previous vs updated snow water equivalent + real(kind=kind_noahmp) :: HeatLhTotPhsChg ! total latent heat of phase change + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyRes ! energy residual [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: GlacierPhaseChg ! melting or freezing glacier water [kg/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatTotInit ! initial total water (ice + liq) mass + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceInit ! initial ice content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqInit ! initial liquid content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceTmp ! soil/snow ice mass [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqTmp ! soil/snow liquid water mass [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyResLeft ! energy residual or loss after melting/freezing + +! -------------------------------------------------------------------- + associate( & + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, options for glacier treatment + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! in, energy factor for soil & snow phase change + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + IndexPhaseChange => noahmp%water%state%IndexPhaseChange ,& ! out, phase change index [0-none;1-melt;2-refreeze] + MeltGroundSnow => noahmp%water%flux%MeltGroundSnow ,& ! out, ground snowmelt rate [mm/s] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt & ! out, surface ponding [mm] from snowmelt when thin snow has no layer + ) +! ---------------------------------------------------------------------- + + !--- Initialization + if (.not. allocated(EnergyRes) ) allocate(EnergyRes (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(GlacierPhaseChg)) allocate(GlacierPhaseChg(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatTotInit) ) allocate(MassWatTotInit (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceInit) ) allocate(MassWatIceInit (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqInit) ) allocate(MassWatLiqInit (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceTmp) ) allocate(MassWatIceTmp (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqTmp) ) allocate(MassWatLiqTmp (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(EnergyResLeft) ) allocate(EnergyResLeft (-NumSnowLayerMax+1:NumSoilLayer)) + EnergyRes = 0.0 + GlacierPhaseChg = 0.0 + MassWatTotInit = 0.0 + MassWatIceInit = 0.0 + MassWatLiqInit = 0.0 + MassWatIceTmp = 0.0 + MassWatLiqTmp = 0.0 + EnergyResLeft = 0.0 + MeltGroundSnow = 0.0 + PondSfcThinSnwMelt = 0.0 + HeatLhTotPhsChg = 0.0 + + !--- treat snowpack over glacier ice first + + ! snow layer water mass + do LoopInd1 = NumSnowLayerNeg+1, 0 + MassWatIceTmp(LoopInd1) = SnowIce(LoopInd1) + MassWatLiqTmp(LoopInd1) = SnowLiqWater(LoopInd1) + enddo + + ! other required variables + do LoopInd1 = NumSnowLayerNeg+1, 0 + IndexPhaseChange(LoopInd1) = 0 + EnergyRes (LoopInd1) = 0.0 + GlacierPhaseChg (LoopInd1) = 0.0 + EnergyResLeft (LoopInd1) = 0.0 + MassWatIceInit (LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqInit (LoopInd1) = MassWatLiqTmp(LoopInd1) + MassWatTotInit (LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqTmp(LoopInd1) + enddo + + ! determine melting or freezing state + do LoopInd1 = NumSnowLayerNeg+1, 0 + if ( (MassWatIceTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) >= ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 1 ! melting + endif + if ( (MassWatLiqTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) < ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 2 ! freezing + endif + enddo + + ! Calculate the energy surplus and loss for melting and freezing + do LoopInd1 = NumSnowLayerNeg+1, 0 + if ( IndexPhaseChange(LoopInd1) > 0 ) then + EnergyRes(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + endif + if ( (IndexPhaseChange(LoopInd1) == 1) .and. (EnergyRes(LoopInd1) < 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + if ( (IndexPhaseChange(LoopInd1) == 2) .and. (EnergyRes(LoopInd1) > 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + GlacierPhaseChg(LoopInd1) = EnergyRes(LoopInd1) * MainTimeStep / ConstLatHeatFusion + enddo + + ! The rate of melting for snow without a layer, needs more work. + if ( OptGlacierTreatment == 2 ) then + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (TemperatureSoilSnow(1) > ConstFreezePoint) ) then + EnergyRes(1) = (TemperatureSoilSnow(1) - ConstFreezePoint) / PhaseChgFacSoilSnow(1) ! available heat + TemperatureSoilSnow(1) = ConstFreezePoint ! set T to freezing + GlacierPhaseChg(1) = EnergyRes(1) * MainTimeStep / ConstLatHeatFusion ! total snow melt possible + SnowWaterPrev = SnowWaterEquiv + SnowWaterEquiv = max(0.0, SnowWaterPrev-GlacierPhaseChg(1)) ! snow remaining + SnowWaterRatio = SnowWaterEquiv / SnowWaterPrev ! fraction melted + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth) ! new snow height + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit to a reasonable snow density + EnergyResLeft(1) = EnergyRes(1) - ConstLatHeatFusion * (SnowWaterPrev - SnowWaterEquiv) / MainTimeStep ! excess heat + if ( EnergyResLeft(1) > 0.0 ) then + GlacierPhaseChg(1) = EnergyResLeft(1) * MainTimeStep / ConstLatHeatFusion + TemperatureSoilSnow(1) = TemperatureSoilSnow(1) + PhaseChgFacSoilSnow(1) * EnergyResLeft(1) ! re-heat ice + else + GlacierPhaseChg(1) = 0.0 + EnergyRes(1) = 0.0 + endif + MeltGroundSnow = max(0.0, SnowWaterPrev-SnowWaterEquiv) / MainTimeStep ! melted snow rate + HeatLhTotPhsChg = ConstLatHeatFusion * MeltGroundSnow ! melted snow energy + PondSfcThinSnwMelt = SnowWaterPrev - SnowWaterEquiv ! melt water + endif + endif ! OptGlacierTreatment==2 + + ! The rate of melting and freezing for multi-layer snow + do LoopInd1 = NumSnowLayerNeg+1, 0 + if ( (IndexPhaseChange(LoopInd1) > 0) .and. (abs(EnergyRes(LoopInd1)) > 0.0) ) then + EnergyResLeft(LoopInd1) = 0.0 + if ( GlacierPhaseChg(LoopInd1) > 0.0 ) then + MassWatIceTmp(LoopInd1) = max(0.0, MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + elseif ( GlacierPhaseChg(LoopInd1) < 0.0 ) then + MassWatIceTmp(LoopInd1) = min(MassWatTotInit(LoopInd1), MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + endif + MassWatLiqTmp(LoopInd1) = max(0.0, MassWatTotInit(LoopInd1)-MassWatIceTmp(LoopInd1)) ! update liquid water mass + + ! update snow temperature and energy surplus/loss + if ( abs(EnergyResLeft(LoopInd1)) > 0.0 ) then + TemperatureSoilSnow(LoopInd1) = TemperatureSoilSnow(LoopInd1) + & + PhaseChgFacSoilSnow(LoopInd1) * EnergyResLeft(LoopInd1) + if ( (MassWatLiqTmp(LoopInd1)*MassWatIceTmp(LoopInd1)) > 0.0 ) & + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + endif + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + + ! snow melting rate + MeltGroundSnow = MeltGroundSnow + max(0.0, (MassWatIceInit(LoopInd1)-MassWatIceTmp(LoopInd1))) / MainTimeStep + endif + enddo + + !---- glacier ice layer treatment + + if ( OptGlacierTreatment == 1 ) then + + ! ice layer water mass + do LoopInd1 = 1, NumSoilLayer + MassWatLiqTmp(LoopInd1) = SoilLiqWater(LoopInd1) * ThicknessSnowSoilLayer(LoopInd1) * 1000.0 + MassWatIceTmp(LoopInd1) = (SoilMoisture(LoopInd1) - SoilLiqWater(LoopInd1)) * ThicknessSnowSoilLayer(LoopInd1) * 1000.0 + enddo + + ! other required variables + do LoopInd1 = 1, NumSoilLayer + IndexPhaseChange(LoopInd1) = 0 + EnergyRes(LoopInd1) = 0.0 + GlacierPhaseChg(LoopInd1) = 0.0 + EnergyResLeft(LoopInd1) = 0.0 + MassWatIceInit(LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqInit(LoopInd1) = MassWatLiqTmp(LoopInd1) + MassWatTotInit(LoopInd1) = MassWatIceTmp(LoopInd1) + MassWatLiqTmp(LoopInd1) + enddo + + ! determine melting or freezing state + do LoopInd1 = 1, NumSoilLayer + if ( (MassWatIceTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) >= ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 1 ! melting + endif + if ( (MassWatLiqTmp(LoopInd1) > 0.0) .and. (TemperatureSoilSnow(LoopInd1) < ConstFreezePoint) ) then + IndexPhaseChange(LoopInd1) = 2 ! freezing + endif + ! If snow exists, but its thickness is not enough to create a layer + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (LoopInd1 == 1) ) then + if ( TemperatureSoilSnow(LoopInd1) >= ConstFreezePoint ) then + IndexPhaseChange(LoopInd1) = 1 + endif + endif + enddo + + ! Calculate the energy surplus and loss for melting and freezing + do LoopInd1 = 1, NumSoilLayer + if ( IndexPhaseChange(LoopInd1) > 0 ) then + EnergyRes(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + endif + if ( (IndexPhaseChange(LoopInd1) == 1) .and. (EnergyRes(LoopInd1) < 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + if ( (IndexPhaseChange(LoopInd1) == 2) .and. (EnergyRes(LoopInd1) > 0.0) ) then + EnergyRes(LoopInd1) = 0.0 + IndexPhaseChange(LoopInd1) = 0 + endif + GlacierPhaseChg(LoopInd1) = EnergyRes(LoopInd1) * MainTimeStep / ConstLatHeatFusion + enddo + + ! The rate of melting for snow without a layer, needs more work. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (GlacierPhaseChg(1) > 0.0) ) then + SnowWaterPrev = SnowWaterEquiv + SnowWaterEquiv = max(0.0, SnowWaterPrev-GlacierPhaseChg(1)) + SnowWaterRatio = SnowWaterEquiv / SnowWaterPrev + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth) + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit to a reasonable snow density + EnergyResLeft(1) = EnergyRes(1) - ConstLatHeatFusion * (SnowWaterPrev - SnowWaterEquiv) / MainTimeStep + if ( EnergyResLeft(1) > 0.0 ) then + GlacierPhaseChg(1) = EnergyResLeft(1) * MainTimeStep / ConstLatHeatFusion + EnergyRes(1) = EnergyResLeft(1) + IndexPhaseChange(1) = 1 + else + GlacierPhaseChg(1) = 0.0 + EnergyRes(1) = 0.0 + IndexPhaseChange(1) = 0 + endif + MeltGroundSnow = max(0.0, (SnowWaterPrev-SnowWaterEquiv)) / MainTimeStep + HeatLhTotPhsChg = ConstLatHeatFusion * MeltGroundSnow + PondSfcThinSnwMelt = SnowWaterPrev - SnowWaterEquiv + endif + + ! The rate of melting and freezing for glacier ice + do LoopInd1 = 1, NumSoilLayer + if ( (IndexPhaseChange(LoopInd1) > 0) .and. (abs(EnergyRes(LoopInd1)) > 0.0) ) then + EnergyResLeft(LoopInd1) = 0.0 + if ( GlacierPhaseChg(LoopInd1) > 0.0 ) then + MassWatIceTmp(LoopInd1) = max(0.0, MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + elseif ( GlacierPhaseChg(LoopInd1) < 0.0 ) then + MassWatIceTmp(LoopInd1) = min(MassWatTotInit(LoopInd1), MassWatIceInit(LoopInd1)-GlacierPhaseChg(LoopInd1)) + EnergyResLeft(LoopInd1) = EnergyRes(LoopInd1) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + endif + MassWatLiqTmp(LoopInd1) = max(0.0, MassWatTotInit(LoopInd1)-MassWatIceTmp(LoopInd1)) ! update liquid water mass + + ! update ice temperature and energy surplus/loss + if ( abs(EnergyResLeft(LoopInd1)) > 0.0 ) then + TemperatureSoilSnow(LoopInd1) = TemperatureSoilSnow(LoopInd1) + & + PhaseChgFacSoilSnow(LoopInd1) * EnergyResLeft(LoopInd1) + endif + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * (MassWatIceInit(LoopInd1) - MassWatIceTmp(LoopInd1)) / MainTimeStep + endif + enddo + EnergyResLeft = 0.0 + GlacierPhaseChg = 0.0 + + !--- Deal with residuals in ice/soil + + ! first remove excess heat by reducing layer temperature + if ( any(TemperatureSoilSnow(1:NumSoilLayer) > ConstFreezePoint) .and. & + any(TemperatureSoilSnow(1:NumSoilLayer) < ConstFreezePoint) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) > ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (TemperatureSoilSnow(LoopInd2) < ConstFreezePoint) .and. & + (EnergyResLeft(LoopInd1) > 0.1) ) then + EnergyResLeft(LoopInd2) = (TemperatureSoilSnow(LoopInd2) - ConstFreezePoint) / & + PhaseChgFacSoilSnow(LoopInd2) + if ( abs(EnergyResLeft(LoopInd2)) > EnergyResLeft(LoopInd1) ) then ! LAYER ABSORBS ALL + EnergyResLeft(LoopInd2) = EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd1) + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + & + EnergyResLeft(LoopInd2) * PhaseChgFacSoilSnow(LoopInd2) + EnergyResLeft(LoopInd1) = 0.0 + else + EnergyResLeft(LoopInd1) = EnergyResLeft(LoopInd1) + EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd2) = 0.0 + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + endif + enddo + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + ! now remove excess cold by increasing temperture (may not be necessary with above loop) + if ( any(TemperatureSoilSnow(1:NumSoilLayer) > ConstFreezePoint) .and. & + any(TemperatureSoilSnow(1:NumSoilLayer) < ConstFreezePoint) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) < ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (TemperatureSoilSnow(LoopInd2) > ConstFreezePoint) .and. & + (EnergyResLeft(LoopInd1) < -0.1) ) then + EnergyResLeft(LoopInd2) = (TemperatureSoilSnow(LoopInd2) - ConstFreezePoint) / & + PhaseChgFacSoilSnow(LoopInd2) + if ( EnergyResLeft(LoopInd2) > abs(EnergyResLeft(LoopInd1)) ) then ! LAYER ABSORBS ALL + EnergyResLeft(LoopInd2) = EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd1) + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + & + EnergyResLeft(LoopInd2) * PhaseChgFacSoilSnow(LoopInd2) + EnergyResLeft(LoopInd1) = 0.0 + else + EnergyResLeft(LoopInd1) = EnergyResLeft(LoopInd1) + EnergyResLeft(LoopInd2) + EnergyResLeft(LoopInd2) = 0.0 + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + endif + enddo + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + ! now remove excess heat by melting ice + if ( any(TemperatureSoilSnow(1:NumSoilLayer) > ConstFreezePoint) .and. & + any(MassWatIceTmp(1:NumSoilLayer) > 0.0) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) > ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + GlacierPhaseChg(LoopInd1) = EnergyResLeft(LoopInd1) * MainTimeStep / ConstLatHeatFusion + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (MassWatIceTmp(LoopInd2) > 0.0) .and. & + (GlacierPhaseChg(LoopInd1) > 0.1) ) then + if ( MassWatIceTmp(LoopInd2) > GlacierPhaseChg(LoopInd1) ) then ! LAYER ABSORBS ALL + MassWatIceTmp(LoopInd2) = MassWatIceTmp(LoopInd2) - GlacierPhaseChg(LoopInd1) + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * GlacierPhaseChg(LoopInd1)/MainTimeStep + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + GlacierPhaseChg(LoopInd1) = 0.0 + else + GlacierPhaseChg(LoopInd1) = GlacierPhaseChg(LoopInd1) - MassWatIceTmp(LoopInd2) + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * MassWatIceTmp(LoopInd2) / MainTimeStep + MassWatIceTmp(LoopInd2) = 0.0 + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + MassWatLiqTmp(LoopInd2) = max(0.0, MassWatTotInit(LoopInd2)-MassWatIceTmp(LoopInd2)) + endif + enddo + EnergyResLeft(LoopInd1) = GlacierPhaseChg(LoopInd1) * ConstLatHeatFusion / MainTimeStep + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + ! snow remove excess cold by refreezing liquid (may not be necessary with above loop) + if ( any(TemperatureSoilSnow(1:NumSoilLayer) < ConstFreezePoint) .and. & + any(MassWatLiqTmp(1:NumSoilLayer) > 0.0) ) then + do LoopInd1 = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd1) < ConstFreezePoint ) then + EnergyResLeft(LoopInd1) = (TemperatureSoilSnow(LoopInd1) - ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd1) + GlacierPhaseChg(LoopInd1) = EnergyResLeft(LoopInd1) * MainTimeStep / ConstLatHeatFusion + do LoopInd2 = 1, NumSoilLayer + if ( (LoopInd1 /= LoopInd2) .and. (MassWatLiqTmp(LoopInd2) > 0.0) .and. & + (GlacierPhaseChg(LoopInd1) < -0.1) ) then + if ( MassWatLiqTmp(LoopInd2) > abs(GlacierPhaseChg(LoopInd1)) ) then ! LAYER ABSORBS ALL + MassWatIceTmp(LoopInd2) = MassWatIceTmp(LoopInd2) - GlacierPhaseChg(LoopInd1) + HeatLhTotPhsChg = HeatLhTotPhsChg + & + ConstLatHeatFusion * GlacierPhaseChg(LoopInd1) / MainTimeStep + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + GlacierPhaseChg(LoopInd1) = 0.0 + else + GlacierPhaseChg(LoopInd1) = GlacierPhaseChg(LoopInd1) + MassWatLiqTmp(LoopInd2) + HeatLhTotPhsChg = HeatLhTotPhsChg - & + ConstLatHeatFusion * MassWatLiqTmp(LoopInd2) / MainTimeStep + MassWatIceTmp(LoopInd2) = MassWatTotInit(LoopInd2) + TemperatureSoilSnow(LoopInd2) = ConstFreezePoint + endif + MassWatLiqTmp(LoopInd2) = max(0.0, MassWatTotInit(LoopInd2)-MassWatIceTmp(LoopInd2)) + endif + enddo + EnergyResLeft(LoopInd1) = GlacierPhaseChg(LoopInd1) * ConstLatHeatFusion / MainTimeStep + TemperatureSoilSnow(LoopInd1) = ConstFreezePoint + EnergyResLeft(LoopInd1) * PhaseChgFacSoilSnow(LoopInd1) + endif + enddo + endif + + endif ! OptGlacierTreatment==1 + + !--- update snow and soil ice and liquid content + do LoopInd1 = NumSnowLayerNeg+1, 0 ! snow + SnowLiqWater(LoopInd1) = MassWatLiqTmp(LoopInd1) + SnowIce(LoopInd1) = MassWatIceTmp(LoopInd1) + enddo + do LoopInd1 = 1, NumSoilLayer ! glacier ice + if ( OptGlacierTreatment == 1 ) then + SoilLiqWater(LoopInd1) = MassWatLiqTmp(LoopInd1) / (1000.0 * ThicknessSnowSoilLayer(LoopInd1)) + SoilLiqWater(LoopInd1) = max(0.0, min(1.0,SoilLiqWater(LoopInd1))) + elseif ( OptGlacierTreatment == 2 ) then + SoilLiqWater(LoopInd1) = 0.0 ! ice, assume all frozen forever + endif + SoilMoisture(LoopInd1) = 1.0 + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(EnergyRes ) + deallocate(GlacierPhaseChg) + deallocate(MassWatTotInit ) + deallocate(MassWatIceInit ) + deallocate(MassWatLiqInit ) + deallocate(MassWatIceTmp ) + deallocate(MassWatLiqTmp ) + deallocate(EnergyResLeft ) + + end associate + + end subroutine GlacierPhaseChange + +end module GlacierPhaseChangeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureMainMod.F90 new file mode 100644 index 0000000000..8093807748 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureMainMod.F90 @@ -0,0 +1,80 @@ +module GlacierTemperatureMainMod + +!!! Main module to compute snow (if exists) and glacier ice temperature. +!!! Note that snow temperatures during melting season may exceed melting +!!! point but later in GlacierPhaseChange subroutine the snow +!!! temperatures are reset to melting point for melting snow. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use GlacierTemperatureSolverMod, only : GlacierTemperatureSolver + use GlacierThermalDiffusionMod, only : GlacierThermalDiffusion + + implicit none + +contains + + subroutine GlacierTemperatureMain(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TSNOSOI_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3 ! left-hand side term of the matrix + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of glacier/soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + DepthSoilTempBottom => noahmp%config%domain%DepthSoilTempBottom ,& ! in, depth [m] from glacier surface for lower soil temperature boundary + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! out, depth of lower boundary condition [m] from snow surface + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd & ! out, light penetrating through snow/ice [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRight)) allocate(MatRight(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft1)) allocate(MatLeft1(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft2)) allocate(MatLeft2(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3)) allocate(MatLeft3(-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + + ! compute solar penetration through water, needs more work + RadSwPenetrateGrd(NumSnowLayerNeg+1:NumSoilLayer) = 0.0 + + ! adjust DepthSoilTempBottom from glacier ice surface to DepthSoilTempBotToSno from snow surface + DepthSoilTempBotToSno = DepthSoilTempBottom - SnowDepth + + ! compute soil temperatures + call GlacierThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + call GlacierTemperatureSolver(noahmp, MainTimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRight) + deallocate(MatLeft1) + deallocate(MatLeft2) + deallocate(MatLeft3) + + end associate + + end subroutine GlacierTemperatureMain + +end module GlacierTemperatureMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureSolverMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureSolverMod.F90 new file mode 100644 index 0000000000..e94beb5f55 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierTemperatureSolverMod.F90 @@ -0,0 +1,84 @@ +module GlacierTemperatureSolverMod + +!!! Compute Glacier and snow layer temperature using tri-diagonal matrix solution +!!! Dependent on the output from GlacierThermalDiffusion module + + use Machine + use NoahmpVarType + use ConstantDefineMod + use MatrixSolverTriDiagonalMod, only : MatrixSolverTriDiagonal + + implicit none + +contains + + subroutine GlacierTemperatureSolver(noahmp, TimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HSTEP_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! layer loop index + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRightTmp ! temporary MatRight matrix coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3Tmp ! temporary MatLeft3 matrix coefficient + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of glacier/soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow & ! inout, snow and glacier layer temperature [K] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRightTmp)) allocate(MatRightTmp(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3Tmp)) allocate(MatLeft3Tmp(-NumSnowLayerMax+1:NumSoilLayer)) + MatRightTmp = 0.0 + MatLeft3Tmp = 0.0 + + ! update tri-diagonal matrix elements + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRight(LoopInd) = MatRight(LoopInd) * TimeStep + MatLeft1(LoopInd) = MatLeft1(LoopInd) * TimeStep + MatLeft2(LoopInd) = 1.0 + MatLeft2(LoopInd) * TimeStep + MatLeft3(LoopInd) = MatLeft3(LoopInd) * TimeStep + enddo + + ! copy values for input variables before call to rosr12 + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRightTmp(LoopInd) = MatRight(LoopInd) + MatLeft3Tmp(LoopInd) = MatLeft3(LoopInd) + enddo + + ! solve the tri-diagonal matrix equation + call MatrixSolverTriDiagonal(MatLeft3,MatLeft1,MatLeft2,MatLeft3Tmp,MatRightTmp,MatRight,& + NumSnowLayerNeg+1,NumSoilLayer,NumSnowLayerMax) + + ! update snow & glacier temperature + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + TemperatureSoilSnow(LoopInd) = TemperatureSoilSnow(LoopInd) + MatLeft3(LoopInd) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRightTmp) + deallocate(MatLeft3Tmp) + + end associate + + end subroutine GlacierTemperatureSolver + +end module GlacierTemperatureSolverMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GlacierThermalDiffusionMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GlacierThermalDiffusionMod.F90 new file mode 100644 index 0000000000..0eb8e66cc0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GlacierThermalDiffusionMod.F90 @@ -0,0 +1,141 @@ +module GlacierThermalDiffusionMod + +!!! Solve glacier ice and snow layer thermal diffusion +!!! Calculate the right hand side of the time tendency term of the glacier +!!! and snow thermal diffusion equation. Currently snow and glacier ice layers +!!! are coupled in solving the equations. Also compute/prepare the matrix +!!! coefficients for the tri-diagonal matrix of the implicit time scheme. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GlacierThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HRT_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: DepthSnowSoilTmp ! temporary snow/soil layer depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilInv ! inverse of snow/soil layer depth [1/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacPerArea ! Heat capacity of soil/snow per area [J/m2/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: TempGradDepth ! temperature gradient (derivative) with soil/snow depth [K/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyExcess ! energy flux excess in soil/snow [W/m2] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + OptSoilTemperatureBottom => noahmp%config%nmlist%OptSoilTemperatureBottom ,& ! in, options for lower boundary condition of soil temperature + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + TemperatureSoilBottom => noahmp%forcing%TemperatureSoilBottom ,& ! in, bottom boundary soil temperature [K] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! in, depth of lower boundary condition [m] from snow surface + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! in, heat capacity [J/m3/K] for all soil & snow + HeatGroundTot => noahmp%energy%flux%HeatGroundTot ,& ! in, total ground heat flux [W/m2] (+ to soil/snow) + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd ,& ! in, light penetrating through soil/snow water [W/m2] + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot & ! out, energy influx from soil bottom [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSnowSoilInv)) allocate(DepthSnowSoilInv(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(HeatCapacPerArea)) allocate(HeatCapacPerArea(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(TempGradDepth) ) allocate(TempGradDepth (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(EnergyExcess) ) allocate(EnergyExcess (-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + DepthSnowSoilInv(:) = 0.0 + HeatCapacPerArea(:) = 0.0 + TempGradDepth(:) = 0.0 + EnergyExcess(:) = 0.0 + + ! compute gradient and flux of glacier/snow thermal diffusion + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + HeatCapacPerArea(LoopInd) = - DepthSnowSoilLayer(LoopInd) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) - & + HeatGroundTot - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd < NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = (ThermConductSoilSnow(LoopInd)*TempGradDepth(LoopInd) - & + ThermConductSoilSnow(LoopInd-1)*TempGradDepth(LoopInd-1) ) - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd == NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + if ( OptSoilTemperatureBottom == 1 ) then + HeatFromSoilBot = 0.0 + endif + if ( OptSoilTemperatureBottom == 2 ) then + TempGradDepth(LoopInd) = (TemperatureSoilSnow(LoopInd) - TemperatureSoilBottom) / & + (0.5 * (DepthSnowSoilLayer(LoopInd-1)+DepthSnowSoilLayer(LoopInd)) - DepthSoilTempBotToSno) + HeatFromSoilBot = -ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) + endif + EnergyExcess(LoopInd) = (-HeatFromSoilBot - ThermConductSoilSnow(LoopInd-1)*TempGradDepth(LoopInd-1)) - & + RadSwPenetrateGrd(LoopInd) + endif + enddo + + ! prepare the matrix coefficients for the tri-diagonal matrix + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + MatLeft1(LoopInd) = 0.0 + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd) * DepthSnowSoilInv(LoopInd) / HeatCapacPerArea(LoopInd) + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + endif + if ( OptSnowSoilTempTime == 2 ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + ThermConductSoilSnow(LoopInd) / & + (0.5*DepthSnowSoilLayer(LoopInd)*DepthSnowSoilLayer(LoopInd)*HeatCapacSoilSnow(LoopInd)) + endif + elseif ( LoopInd < NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd ) * DepthSnowSoilInv(LoopInd ) / HeatCapacPerArea(LoopInd) + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3 (LoopInd)) + elseif ( LoopInd == NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = 0.0 + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + endif + MatRight(LoopInd) = EnergyExcess(LoopInd) / (-HeatCapacPerArea(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSnowSoilInv) + deallocate(HeatCapacPerArea) + deallocate(TempGradDepth ) + deallocate(EnergyExcess ) + + end associate + + end subroutine GlacierThermalDiffusion + +end module GlacierThermalDiffusionMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoGlacierMod.F90 new file mode 100644 index 0000000000..5e876a59b2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoGlacierMod.F90 @@ -0,0 +1,51 @@ +module GroundAlbedoGlacierMod + +!!! Compute glacier ground albedo based on snow and ice albedo + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundAlbedoGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RADIATION_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSwBnd ! solar radiation band index + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + AlbedoLandIce => noahmp%energy%param%AlbedoLandIce ,& ! in, albedo land ice: 1=vis, 2=nir + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! in, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! in, snow albedo for diffuse(1=vis, 2=nir) + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif & ! out, ground albedo (diffuse: vis, nir) + ) +! ---------------------------------------------------------------------- + + do IndSwBnd = 1, NumSwRadBand + + AlbedoGrdDir(IndSwBnd) = AlbedoLandIce(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDir(IndSwBnd)*SnowCoverFrac + AlbedoGrdDif(IndSwBnd) = AlbedoLandIce(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDif(IndSwBnd)*SnowCoverFrac + + enddo + + end associate + + end subroutine GroundAlbedoGlacier + +end module GroundAlbedoGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoMod.F90 new file mode 100644 index 0000000000..6ca4b10566 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundAlbedoMod.F90 @@ -0,0 +1,73 @@ +module GroundAlbedoMod + +!!! Compute ground albedo based on soil and snow albedo + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundAlbedo(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GROUNDALB +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSwBnd ! solar radiation band index + real(kind=kind_noahmp) :: AlbedoSoilAdjWet ! soil water correction factor for soil albedo + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + AlbedoSoilSat => noahmp%energy%param%AlbedoSoilSat ,& ! in, saturated soil albedos: 1=vis, 2=nir + AlbedoSoilDry => noahmp%energy%param%AlbedoSoilDry ,& ! in, dry soil albedos: 1=vis, 2=nir + AlbedoLakeFrz => noahmp%energy%param%AlbedoLakeFrz ,& ! in, albedo frozen lakes: 1=vis, 2=nir + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! in, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! in, snow albedo for diffuse(1=vis, 2=nir) + AlbedoSoilDir => noahmp%energy%state%AlbedoSoilDir ,& ! out, soil albedo (direct) + AlbedoSoilDif => noahmp%energy%state%AlbedoSoilDif ,& ! out, soil albedo (diffuse) + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif & ! out, ground albedo (diffuse: vis, nir) + ) +! ---------------------------------------------------------------------- + + do IndSwBnd = 1, NumSwRadBand + + AlbedoSoilAdjWet = max(0.11-0.40*SoilMoisture(1), 0.0) + + if ( SurfaceType == 1 ) then ! soil + AlbedoSoilDir(IndSwBnd) = min(AlbedoSoilSat(IndSwBnd)+AlbedoSoilAdjWet, AlbedoSoilDry(IndSwBnd)) + AlbedoSoilDif(IndSwBnd) = AlbedoSoilDir(IndSwBnd) + elseif ( TemperatureGrd > ConstFreezePoint ) then ! unfrozen lake, wetland + AlbedoSoilDir(IndSwBnd) = 0.06 / (max(0.01, CosSolarZenithAngle)**1.7+0.15) + AlbedoSoilDif(IndSwBnd) = 0.06 + else ! frozen lake, wetland + AlbedoSoilDir(IndSwBnd) = AlbedoLakeFrz(IndSwBnd) + AlbedoSoilDif(IndSwBnd) = AlbedoSoilDir(IndSwBnd) + endif + + AlbedoGrdDir(IndSwBnd) = AlbedoSoilDir(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDir(IndSwBnd)*SnowCoverFrac + AlbedoGrdDif(IndSwBnd) = AlbedoSoilDif(IndSwBnd)*(1.0-SnowCoverFrac) + AlbedoSnowDif(IndSwBnd)*SnowCoverFrac + + enddo + + end associate + + end subroutine GroundAlbedo + +end module GroundAlbedoMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyGlacierMod.F90 new file mode 100644 index 0000000000..785ac62ade --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyGlacierMod.F90 @@ -0,0 +1,54 @@ +module GroundRoughnessPropertyGlacierMod + +!!! Compute glacier ground roughness length, displacement height, and surface reference height + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundRoughnessPropertyGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + RefHeightAboveSfc => noahmp%config%domain%RefHeightAboveSfc ,& ! in, reference height [m] above surface zero plane + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + RoughLenMomSnow => noahmp%energy%param%RoughLenMomSnow ,& ! in, snow surface roughness length [m] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! out, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length [m], momentum, ground + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! out, surface zero plane displacement [m] + ZeroPlaneDispGrd => noahmp%energy%state%ZeroPlaneDispGrd ,& ! out, ground zero plane displacement [m] + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd & ! out, reference height [m] above ground + ) +! ---------------------------------------------------------------------- + + ! ground roughness length + RoughLenMomGrd = RoughLenMomSnow + RoughLenMomSfc = RoughLenMomGrd + + ! surface roughness length and displacement height + ZeroPlaneDispGrd = SnowDepth + ZeroPlaneDispSfc = ZeroPlaneDispGrd + + ! reference height above ground + RefHeightAboveGrd = ZeroPlaneDispSfc + RefHeightAboveSfc + + end associate + + end subroutine GroundRoughnessPropertyGlacier + +end module GroundRoughnessPropertyGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyMod.F90 new file mode 100644 index 0000000000..9394131883 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundRoughnessPropertyMod.F90 @@ -0,0 +1,86 @@ +module GroundRoughnessPropertyMod + +!!! Compute ground roughness length, displacement height, and surface reference height + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundRoughnessProperty(noahmp, FlagVegSfc) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + logical , intent(in ) :: FlagVegSfc ! flag: true if vegetated surface + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + RefHeightAboveSfc => noahmp%config%domain%RefHeightAboveSfc ,& ! in, reference height [m] above surface zero plane + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + RoughLenMomVeg => noahmp%energy%param%RoughLenMomVeg ,& ! in, momentum roughness length vegetated [m] + RoughLenMomSnow => noahmp%energy%param%RoughLenMomSnow ,& ! in, snow surface roughness length [m] + RoughLenMomSoil => noahmp%energy%param%RoughLenMomSoil ,& ! in, bare-soil roughness length [m] + RoughLenMomLake => noahmp%energy%param%RoughLenMomLake ,& ! in, lake surface roughness length [m] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! out, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! out, roughness length [m], momentum, ground + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! out, surface zero plane displacement [m] + ZeroPlaneDispGrd => noahmp%energy%state%ZeroPlaneDispGrd ,& ! out, ground zero plane displacement [m] + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd & ! out, reference height [m] above ground + ) +! ---------------------------------------------------------------------- + + ! ground roughness length + if ( SurfaceType == 2 ) then ! Lake + if ( TemperatureGrd <= ConstFreezePoint ) then + RoughLenMomGrd = RoughLenMomLake * (1.0-SnowCoverFrac) + SnowCoverFrac * RoughLenMomSnow + else + RoughLenMomGrd = RoughLenMomLake + endif + else ! soil + RoughLenMomGrd = RoughLenMomSoil * (1.0-SnowCoverFrac) + SnowCoverFrac * RoughLenMomSnow + endif + + ! surface roughness length and displacement height + ZeroPlaneDispGrd = SnowDepth + if ( FlagVegSfc .eqv. .true. ) then + RoughLenMomSfc = RoughLenMomVeg + ZeroPlaneDispSfc = 0.65 * HeightCanopyTop + if ( SnowDepth > ZeroPlaneDispSfc ) ZeroPlaneDispSfc = SnowDepth + else + RoughLenMomSfc = RoughLenMomGrd + ZeroPlaneDispSfc = ZeroPlaneDispGrd + endif + + ! special case for urban + if ( FlagUrban .eqv. .true. ) then + RoughLenMomGrd = RoughLenMomVeg + ZeroPlaneDispGrd = 0.65 * HeightCanopyTop + RoughLenMomSfc = RoughLenMomGrd + ZeroPlaneDispSfc = ZeroPlaneDispGrd + endif + + ! reference height above ground + RefHeightAboveGrd = max(ZeroPlaneDispSfc, HeightCanopyTop) + RefHeightAboveSfc + if ( ZeroPlaneDispGrd >= RefHeightAboveGrd ) RefHeightAboveGrd = ZeroPlaneDispGrd + RefHeightAboveSfc + + end associate + + end subroutine GroundRoughnessProperty + +end module GroundRoughnessPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyGlacierMod.F90 new file mode 100644 index 0000000000..62268d9714 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyGlacierMod.F90 @@ -0,0 +1,84 @@ +module GroundThermalPropertyGlacierMod + +!!! Compute snow and glacier ice thermal conductivity and heat capacity + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowThermalPropertyMod, only : SnowThermalProperty + use GlacierIceThermalPropertyMod, only : GlacierIceThermalProperty + + implicit none + +contains + + subroutine GroundThermalPropertyGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: THERMOPROP_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! out, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! out, heat capacity [J/m3/K] for all soil & snow + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! out, energy factor for soil & snow phase change + HeatCapacVolSnow => noahmp%energy%state%HeatCapacVolSnow ,& ! out, snow layer volumetric specific heat [J/m3/K] + ThermConductSnow => noahmp%energy%state%ThermConductSnow ,& ! out, snow layer thermal conductivity [W/m/K] + HeatCapacGlaIce => noahmp%energy%state%HeatCapacGlaIce ,& ! out, glacier ice layer volumetric specific heat [J/m3/K] + ThermConductGlaIce => noahmp%energy%state%ThermConductGlaIce & ! out, glacier ice layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initialize + HeatCapacSoilSnow = 0.0 + ThermConductSoilSnow = 0.0 + + ! compute snow thermal conductivity and heat capacity + call SnowThermalProperty(noahmp) + do LoopInd = NumSnowLayerNeg+1, 0 + ThermConductSoilSnow(LoopInd) = ThermConductSnow(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacVolSnow(LoopInd) + enddo + + ! compute glacier ice thermal properties (using Noah glacial ice approximations) + call GlacierIceThermalProperty(noahmp) + do LoopInd = 1, NumSoilLayer + ThermConductSoilSnow(LoopInd) = ThermConductGlaIce(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacGlaIce(LoopInd) + enddo + + ! combine a temporary variable used for melting/freezing of snow and glacier ice + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + PhaseChgFacSoilSnow(LoopInd) = MainTimeStep / (HeatCapacSoilSnow(LoopInd)*ThicknessSnowSoilLayer(LoopInd)) + enddo + + ! snow/glacier ice interface + if ( NumSnowLayerNeg == 0 ) then + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + 0.35*SnowDepth) / & + (SnowDepth + ThicknessSnowSoilLayer(1)) + else + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + & + ThermConductSoilSnow(0)*ThicknessSnowSoilLayer(0)) / & + (ThicknessSnowSoilLayer(0) + ThicknessSnowSoilLayer(1)) + endif + + end associate + + end subroutine GroundThermalPropertyGlacier + +end module GroundThermalPropertyGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyMod.F90 new file mode 100644 index 0000000000..a8b28ed51a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundThermalPropertyMod.F90 @@ -0,0 +1,111 @@ +module GroundThermalPropertyMod + +!!! Compute snow and soil thermal conductivity and heat capacity + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowThermalPropertyMod, only : SnowThermalProperty + use SoilThermalPropertyMod, only : SoilThermalProperty + + implicit none + +contains + + subroutine GroundThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: THERMOPROP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! out, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! out, heat capacity [J/m3/K] for all soil & snow + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! out, energy factor for soil & snow phase change + HeatCapacVolSnow => noahmp%energy%state%HeatCapacVolSnow ,& ! out, snow layer volumetric specific heat [J/m3/K] + ThermConductSnow => noahmp%energy%state%ThermConductSnow ,& ! out, snow layer thermal conductivity [W/m/K] + HeatCapacVolSoil => noahmp%energy%state%HeatCapacVolSoil ,& ! out, soil layer volumetric specific heat [J/m3/K] + ThermConductSoil => noahmp%energy%state%ThermConductSoil & ! out, soil layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initialize + HeatCapacSoilSnow = 0.0 + ThermConductSoilSnow = 0.0 + + ! compute snow thermal conductivity and heat capacity + call SnowThermalProperty(noahmp) + do LoopInd = NumSnowLayerNeg+1, 0 + ThermConductSoilSnow(LoopInd) = ThermConductSnow(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacVolSnow(LoopInd) + enddo + + ! compute soil thermal properties + call SoilThermalProperty(noahmp) + do LoopInd = 1, NumSoilLayer + ThermConductSoilSnow(LoopInd) = ThermConductSoil(LoopInd) + HeatCapacSoilSnow(LoopInd) = HeatCapacVolSoil(LoopInd) + enddo + if ( FlagUrban .eqv. .true. ) then + do LoopInd = 1, NumSoilLayer + ThermConductSoilSnow(LoopInd) = 3.24 + enddo + endif + + ! heat flux reduction effect from the overlying green canopy, adapted from + ! section 2.1.2 of Peters-Lidard et al. (1997, JGR, VOL 102(D4)). + ! not in use because of the separation of the canopy layer from the ground. + ! but this may represent the effects of leaf litter (Niu comments) + ! ThermConductSoilSnow(1) = ThermConductSoilSnow(1) * EXP (SBETA * VegFracGreen) + + ! compute lake thermal properties (no consideration of turbulent mixing for this version) + if ( SurfaceType == 2 ) then + do LoopInd = 1, NumSoilLayer + if ( TemperatureSoilSnow(LoopInd) > ConstFreezePoint) then + HeatCapacSoilSnow(LoopInd) = ConstHeatCapacWater + ThermConductSoilSnow(LoopInd) = ConstThermConductWater !+ KEDDY * ConstHeatCapacWater + else + HeatCapacSoilSnow(LoopInd) = ConstHeatCapacIce + ThermConductSoilSnow(LoopInd) = ConstThermConductIce + endif + enddo + endif + + ! combine a temporary variable used for melting/freezing of snow and frozen soil + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + PhaseChgFacSoilSnow(LoopInd) = MainTimeStep / (HeatCapacSoilSnow(LoopInd) * ThicknessSnowSoilLayer(LoopInd)) + enddo + + ! snow/soil interface + if ( NumSnowLayerNeg == 0 ) then + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + 0.35*SnowDepth) / & + (SnowDepth + ThicknessSnowSoilLayer(1)) + else + ThermConductSoilSnow(1) = (ThermConductSoilSnow(1)*ThicknessSnowSoilLayer(1) + & + ThermConductSoilSnow(0)*ThicknessSnowSoilLayer(0)) / & + (ThicknessSnowSoilLayer(0) + ThicknessSnowSoilLayer(1)) + endif + + end associate + + end subroutine GroundThermalProperty + +end module GroundThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterMmfMod.F90 new file mode 100644 index 0000000000..da9ef7c9cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterMmfMod.F90 @@ -0,0 +1,691 @@ +module GroundWaterMmfMod + +!!! Module to calculate lateral groundwater flow and the flux between groundwater and rivers +!!! plus the routine to update soil moisture and water table due to those two fluxes +!!! according to the Miguez-Macho & Fan groundwater scheme (Miguez-Macho et al., JGR 2007). +!!! Module written by Gonzalo Miguez-Macho , U. de Santiago de Compostela, Galicia, Spain +!!! November 2012 + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: module_sf_groundwater.F +! Original code: Miguez-Macho&Fan (Miguez-Macho et al 2007, Fan et al 2007) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! Note: this MMF scheme needs further refactoring +! ------------------------------------------------------------------------- + + use NoahmpIOVarType + use NoahmpVarType + use Machine + + implicit none + +contains + + subroutine WTABLE_mmf_noahmp (NoahmpIO ,NSOIL ,XLAND ,XICE ,XICE_THRESHOLD,& + ISICE ,ISLTYP ,SMOISEQ ,DZS ,WTDDT ,& !in + FDEPTH ,AREA ,TOPO ,ISURBAN ,IVGTYP ,& !in + RIVERCOND ,RIVERBED ,EQWTD ,PEXP ,& !in + SMOIS ,SH2OXY ,SMCWTD ,WTD , QLAT, QRF ,& !inout + DEEPRECH ,QSPRING ,QSLAT ,QRFS ,QSPRINGS ,RECH ,& !inout + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! ---------------------------------------------------------------------- +! USE NOAHMP_TABLES, ONLY: BEXP_TABLE, DKSAT_TABLE, SMCMAX_TABLE,PSISAT_TABLE, SMCWLT_TABLE +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! IN only + + type(NoahmpIO_type), intent(in) :: NoahmpIO + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + REAL, INTENT(IN) :: WTDDT + REAL, INTENT(IN) :: XICE_THRESHOLD + INTEGER, INTENT(IN ) :: ISICE + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(IN ) :: XLAND, & + XICE + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: ISLTYP, & + IVGTYP + INTEGER, INTENT(IN) :: nsoil + INTEGER, INTENT(IN) :: ISURBAN + REAL, DIMENSION( ims:ime , 1:nsoil, jms:jme ), & + & INTENT(IN) :: SMOISEQ + REAL, DIMENSION(1:nsoil), INTENT(IN) :: DZS + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(IN) :: FDEPTH, & + AREA, & + TOPO, & + EQWTD, & + PEXP, & + RIVERBED, & + RIVERCOND + +! IN and OUT + + REAL, DIMENSION( ims:ime , 1:nsoil, jms:jme ), & + & INTENT(INOUT) :: SMOIS, & + & SH2OXY + + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(INOUT) :: WTD, & + SMCWTD, & + DEEPRECH, & + QSLAT, & + QRFS, & + QSPRINGS, & + RECH + +!OUT + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(OUT) :: QRF, & !groundwater - river water flux + QSPRING !water springing at the surface from groundwater convergence in the column + +!LOCAL + + INTEGER :: I,J,K + REAL, DIMENSION( 0:NSOIL) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION( 1:NSOIL) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL, DIMENSION( 1:NSOIL) :: SMC,SH2O + REAL :: DELTAT,RCOND,TOTWATER,PSI & + ,WFLUXDEEP,WCNDDEEP,DDZ,SMCWTDMID & + ,WPLUS,WMINUS + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: QLAT + INTEGER, DIMENSION( ims:ime, jms:jme ) :: LANDMASK !-1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations. + + REAL :: BEXP,DKSAT,PSISAT,SMCMAX,SMCWLT + + DELTAT = WTDDT * 60. !timestep in seconds for this calculation + + ZSOIL(0) = 0. + ZSOIL(1) = -DZS(1) + DO K = 2, NSOIL + ZSOIL(K) = -DZS(K) + ZSOIL(K-1) + END DO + + WHERE(XLAND-1.5.LT.0..AND.XICE.LT. XICE_THRESHOLD.AND.IVGTYP.NE.ISICE) + LANDMASK=1 + ELSEWHERE + LANDMASK=-1 + ENDWHERE + +!Calculate lateral flow + + QLAT = 0. + CALL LATERALFLOW(NoahmpIO, ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & + ,ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte ) + + +!compute flux from grounwater to rivers in the cell + + DO J=jts,jte + DO I=its,ite + IF(LANDMASK(I,J).GT.0)THEN + IF(WTD(I,J) .GT. RIVERBED(I,J) .AND. EQWTD(I,J) .GT. RIVERBED(I,J)) THEN + RCOND = RIVERCOND(I,J) * EXP(PEXP(I,J)*(WTD(I,J)-EQWTD(I,J))) + ELSE + RCOND = RIVERCOND(I,J) + ENDIF + QRF(I,J) = RCOND * (WTD(I,J)-RIVERBED(I,J)) * DELTAT/AREA(I,J) +!for now, dont allow it to go from river to groundwater + QRF(I,J) = MAX(QRF(I,J),0.) + ELSE + QRF(I,J) = 0. + ENDIF + ENDDO + ENDDO + + DO J=jts,jte + DO I=its,ite + IF(LANDMASK(I,J).GT.0)THEN + + BEXP = NoahmpIO%BEXP_TABLE (ISLTYP(I,J)) + DKSAT = NoahmpIO%DKSAT_TABLE (ISLTYP(I,J)) + PSISAT = -1.0*NoahmpIO%PSISAT_TABLE (ISLTYP(I,J)) + SMCMAX = NoahmpIO%SMCMAX_TABLE (ISLTYP(I,J)) + SMCWLT = NoahmpIO%SMCWLT_TABLE (ISLTYP(I,J)) + + IF(IVGTYP(I,J)==NoahmpIO%ISURBAN)THEN + SMCMAX = 0.45 + SMCWLT = 0.40 + ENDIF + +!for deep water table calculate recharge + IF(WTD(I,J) < ZSOIL(NSOIL)-DZS(NSOIL))THEN +!assume all liquid if the wtd is deep + DDZ = ZSOIL(NSOIL)-WTD(I,J) + SMCWTDMID = 0.5 * (SMCWTD(I,J) + SMCMAX ) + PSI = PSISAT * ( SMCMAX / SMCWTD(I,J) ) ** BEXP + WCNDDEEP = DKSAT * ( SMCWTDMID / SMCMAX ) ** (2.0*BEXP + 3.0) + WFLUXDEEP = - DELTAT * WCNDDEEP * ( (PSISAT-PSI) / DDZ - 1.) +!update deep soil moisture + SMCWTD(I,J) = SMCWTD(I,J) + (DEEPRECH(I,J) - WFLUXDEEP) / DDZ + WPLUS = MAX((SMCWTD(I,J)-SMCMAX), 0.0) * DDZ + WMINUS = MAX((1.E-4-SMCWTD(I,J)), 0.0) * DDZ + SMCWTD(I,J) = MAX( MIN(SMCWTD(I,J),SMCMAX) , 1.E-4) + WFLUXDEEP = WFLUXDEEP + WPLUS - WMINUS + DEEPRECH(I,J) = WFLUXDEEP + ENDIF + + +!Total water flux to or from groundwater in the cell + TOTWATER = QLAT(I,J) - QRF(I,J) + DEEPRECH(I,J) + + SMC(1:NSOIL) = SMOIS(I,1:NSOIL,J) + SH2O(1:NSOIL) = SH2OXY(I,1:NSOIL,J) + SMCEQ(1:NSOIL) = SMOISEQ(I,1:NSOIL,J) + +!Update the water table depth and soil moisture + CALL UPDATEWTD ( NSOIL, DZS , ZSOIL, SMCEQ, SMCMAX, SMCWLT, PSISAT, BEXP ,I , J , &!in + TOTWATER, WTD(I,J), SMC, SH2O, SMCWTD(I,J) , &!inout + QSPRING(I,J) ) !out + +!now update soil moisture + SMOIS(I,1:NSOIL,J) = SMC(1:NSOIL) + SH2OXY(I,1:NSOIL,J) = SH2O(1:NSOIL) + + ENDIF + ENDDO + ENDDO + +!accumulate fluxes for output + + DO J=jts,jte + DO I=its,ite + IF(LANDMASK(I,J).GT.0)THEN + QSLAT(I,J) = QSLAT(I,J) + QLAT(I,J)*1.E3 + QRFS(I,J) = QRFS(I,J) + QRF(I,J)*1.E3 + QSPRINGS(I,J) = QSPRINGS(I,J) + QSPRING(I,J)*1.E3 + RECH(I,J) = RECH(I,J) + DEEPRECH(I,J)*1.E3 +!zero out DEEPRECH + DEEPRECH(I,J) =0. + ENDIF + ENDDO + ENDDO + + end subroutine WTABLE_mmf_noahmp + + +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine LATERALFLOW (NoahmpIO, ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & + ,ids,ide,jds,jde,kds,kde & + ,ims,ime,jms,jme,kms,kme & + ,its,ite,jts,jte,kts,kte ) +! ---------------------------------------------------------------------- +! USE NOAHMP_TABLES, ONLY : DKSAT_TABLE + +#ifdef MPP_LAND + ! MPP_LAND only for HRLDAS Noah-MP/WRF-Hydro - Prasanth Valayamkunnath (06/10/2022) + use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer, global_nx, global_ny, my_id +#endif +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + + type(NoahmpIO_type), intent(in) :: NoahmpIO + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + REAL , INTENT(IN) :: DELTAT + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: ISLTYP, LANDMASK + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FDEPTH,WTD,TOPO,AREA + +!output + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: QLAT + +!local + INTEGER :: I, J, itsh, iteh, jtsh, jteh, nx, ny + REAL :: Q, KLAT + +#ifdef MPP_LAND + ! halo'ed arrays + REAL, DIMENSION(ims-1:ime+1, jms-1:jme+1) :: KCELL, HEAD + integer, dimension(ims-1:ime+1, jms-1:jme+1) :: landmask_h + real, dimension(ims-1:ime+1, jms-1:jme+1) :: area_h, qlat_h +#else + REAL, DIMENSION(ims:ime, jms:jme) :: KCELL, HEAD +#endif + + REAL, DIMENSION(19) :: KLATFACTOR + DATA KLATFACTOR /2.,3.,4.,10.,10.,12.,14.,20.,24.,28.,40.,48.,2.,0.,10.,0.,20.,2.,2./ + + REAL, PARAMETER :: PI = 3.14159265 + REAL, PARAMETER :: FANGLE = 0.22754493 ! = 0.5*sqrt(0.5*tan(pi/8)) + +#ifdef MPP_LAND +! create halo'ed local copies of tile vars + landmask_h(ims:ime, jms:jme) = landmask + area_h(ims:ime, jms:jme) = area + + nx = ((ime-ims) + 1) + 2 ! include halos + ny = ((jme-jms) + 1) + 2 ! include halos + + !copy neighbor's values for landmask and area + call mpp_land_com_integer(landmask_h, nx, ny, 99) + call mpp_land_com_real(area_h, nx, ny, 99) + + itsh=max(its,1) + iteh=min(ite,global_nx) + jtsh=max(jts,1) + jteh=min(jte,global_ny) +#else + itsh=max(its-1,ids) + iteh=min(ite+1,ide-1) + jtsh=max(jts-1,jds) + jteh=min(jte+1,jde-1) +#endif + + DO J=jtsh,jteh + DO I=itsh,iteh + IF(FDEPTH(I,J).GT.0.)THEN + KLAT = NoahmpIO%DKSAT_TABLE(ISLTYP(I,J)) * KLATFACTOR(ISLTYP(I,J)) + IF(WTD(I,J) < -1.5)THEN + KCELL(I,J) = FDEPTH(I,J) * KLAT * EXP( (WTD(I,J) + 1.5) / FDEPTH(I,J) ) + ELSE + KCELL(I,J) = KLAT * ( WTD(I,J) + 1.5 + FDEPTH(I,J) ) + ENDIF + ELSE + KCELL(i,J) = 0. + ENDIF + + HEAD(I,J) = TOPO(I,J) + WTD(I,J) + ENDDO + ENDDO + +#ifdef MPP_LAND +! update neighbors with kcell/head/calculation + call mpp_land_com_real(KCELL, nx, ny, 99) + call mpp_land_com_real(HEAD, nx, ny, 99) + + itsh=max(its,2) + iteh=min(ite,global_nx-1) + jtsh=max(jts,2) + jteh=min(jte,global_ny-1) + + qlat_h = 0. +#else + itsh=max(its,ids+1) + iteh=min(ite,ide-2) + jtsh=max(jts,jds+1) + jteh=min(jte,jde-2) +#endif + + DO J=jtsh,jteh + DO I=itsh,iteh +#ifdef MPP_LAND + IF( landmask_h(I,J).GT.0 )THEN +#else + IF( LANDMASK(I,J).GT.0 )THEN +#endif + Q=0. + + Q = Q + (KCELL(I-1,J+1)+KCELL(I,J)) & + * (HEAD(I-1,J+1)-HEAD(I,J))/SQRT(2.) + + Q = Q + (KCELL(I-1,J)+KCELL(I,J)) & + * (HEAD(I-1,J)-HEAD(I,J)) + + Q = Q + (KCELL(I-1,J-1)+KCELL(I,J)) & + * (HEAD(I-1,J-1)-HEAD(I,J))/SQRT(2.) + + Q = Q + (KCELL(I,J+1)+KCELL(I,J)) & + * (HEAD(I,J+1)-HEAD(I,J)) + + Q = Q + (KCELL(I,J-1)+KCELL(I,J)) & + * (HEAD(I,J-1)-HEAD(I,J)) + + Q = Q + (KCELL(I+1,J+1)+KCELL(I,J)) & + * (HEAD(I+1,J+1)-HEAD(I,J))/SQRT(2.) + + Q = Q + (KCELL(I+1,J)+KCELL(I,J)) & + * (HEAD(I+1,J)-HEAD(I,J)) + + Q = Q + (KCELL(I+1,J-1)+KCELL(I,J)) & + * (HEAD(I+1,J-1)-HEAD(I,J))/SQRT(2.) + + ! Here, Q is in m3/s. To convert to m, divide it by area of the grid cell. +#ifdef MPP_LAND + qlat_h(I, J) = (FANGLE * Q * DELTAT / area_h(I, J)) +#else + QLAT(I,J) = FANGLE* Q * DELTAT / AREA(I,J) +#endif + ENDIF + ENDDO + ENDDO + +#ifdef MPP_LAND +! merge (sum) of all neighbor's edge Q's + call mpp_land_com_real(qlat_h, nx, ny, 1) + qlat = qlat_h(ims:ime, jms:jme) +#endif + + end subroutine LATERALFLOW + + +! ================================================================================================== +! ---------------------------------------------------------------------- + subroutine UPDATEWTD (NSOIL, DZS, ZSOIL ,SMCEQ ,& !in + SMCMAX, SMCWLT, PSISAT, BEXP ,ILOC ,JLOC ,& !in + TOTWATER, WTD ,SMC, SH2O ,SMCWTD ,& !inout + QSPRING ) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: ILOC, JLOC + REAL, INTENT(IN) :: SMCMAX + REAL, INTENT(IN) :: SMCWLT + REAL, INTENT(IN) :: PSISAT + REAL, INTENT(IN) :: BEXP + REAL, DIMENSION( 0:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: DZS ! soil layer thickness [m] +! input-output + REAL , INTENT(INOUT) :: TOTWATER + REAL , INTENT(INOUT) :: WTD + REAL , INTENT(INOUT) :: SMCWTD + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O +! output + REAL , INTENT(OUT) :: QSPRING +!local + INTEGER :: K + INTEGER :: K1 + INTEGER :: IWTD + INTEGER :: KWTD + REAL :: MAXWATUP, MAXWATDW ,WTDOLD + REAL :: WGPMID + REAL :: SYIELDDW + REAL :: DZUP + REAL :: SMCEQDEEP + REAL, DIMENSION( 1:NSOIL) :: SICE +! ------------------------------------------------------------- + + + + QSPRING=0. + + SICE = SMC - SH2O + +iwtd=1 + +!case 1: totwater > 0 (water table going up): +IF(totwater.gt.0.)then + + + if(wtd.ge.zsoil(nsoil))then + + do k=nsoil-1,1,-1 + if(wtd.lt.zsoil(k))exit + enddo + iwtd=k + kwtd=iwtd+1 + +!max water that fits in the layer + maxwatup=dzs(kwtd)*(smcmax-smc(kwtd)) + + if(totwater.le.maxwatup)then + smc(kwtd) = smc(kwtd) + totwater / dzs(kwtd) + smc(kwtd) = min(smc(kwtd),smcmax) + if(smc(kwtd).gt.smceq(kwtd))wtd = min ( ( smc(kwtd)*dzs(kwtd) & + - smceq(kwtd)*zsoil(iwtd) + smcmax*zsoil(kwtd) ) / & + ( smcmax-smceq(kwtd) ) , zsoil(iwtd) ) + totwater=0. + else !water enough to saturate the layer + smc(kwtd) = smcmax + totwater=totwater-maxwatup + k1=iwtd + do k=k1,0,-1 + wtd = zsoil(k) + iwtd=k-1 + if(k.eq.0)exit + maxwatup=dzs(k)*(smcmax-smc(k)) + if(totwater.le.maxwatup)then + smc(k) = smc(k) + totwater / dzs(k) + smc(k) = min(smc(k),smcmax) + if(smc(k).gt.smceq(k))wtd = min ( ( smc(k)*dzs(k) & + - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / & + ( smcmax-smceq(k) ) , zsoil(iwtd) ) + totwater=0. + exit + else + smc(k) = smcmax + totwater=totwater-maxwatup + endif + + enddo + + endif + + elseif(wtd.ge.zsoil(nsoil)-dzs(nsoil))then ! wtd below bottom of soil model + + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + maxwatup=(smcmax-smcwtd)*dzs(nsoil) + + if(totwater.le.maxwatup)then + smcwtd = smcwtd + totwater / dzs(nsoil) + smcwtd = min(smcwtd,smcmax) + if(smcwtd.gt.smceqdeep)wtd = min( ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) , zsoil(nsoil) ) + totwater=0. + else + smcwtd=smcmax + totwater=totwater-maxwatup + do k=nsoil,0,-1 + wtd=zsoil(k) + iwtd=k-1 + if(k.eq.0)exit + maxwatup=dzs(k)*(smcmax-smc(k)) + if(totwater.le.maxwatup)then + smc(k) = min(smc(k) + totwater / dzs(k),smcmax) + if(smc(k).gt.smceq(k))wtd = min ( ( smc(k)*dzs(k) & + - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / & + ( smcmax-smceq(k) ) , zsoil(iwtd) ) + totwater=0. + exit + else + smc(k) = smcmax + totwater=totwater-maxwatup + endif + enddo + endif + +!deep water table + else + + maxwatup=(smcmax-smcwtd)*(zsoil(nsoil)-dzs(nsoil)-wtd) + if(totwater.le.maxwatup)then + wtd = wtd + totwater/(smcmax-smcwtd) + totwater=0. + else + totwater=totwater-maxwatup + wtd=zsoil(nsoil)-dzs(nsoil) + maxwatup=(smcmax-smcwtd)*dzs(nsoil) + if(totwater.le.maxwatup)then + + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + smcwtd = smcwtd + totwater / dzs(nsoil) + smcwtd = min(smcwtd,smcmax) + wtd = ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) + totwater=0. + else + smcwtd=smcmax + totwater=totwater-maxwatup + do k=nsoil,0,-1 + wtd=zsoil(k) + iwtd=k-1 + if(k.eq.0)exit + maxwatup=dzs(k)*(smcmax-smc(k)) + + if(totwater.le.maxwatup)then + smc(k) = smc(k) + totwater / dzs(k) + smc(k) = min(smc(k),smcmax) + if(smc(k).gt.smceq(k))wtd = ( smc(k)*dzs(k) & + - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / & + ( smcmax-smceq(k) ) + totwater=0. + exit + else + smc(k) = smcmax + totwater=totwater-maxwatup + endif + enddo + endif + endif + endif + +!water springing at the surface + qspring=totwater + +!case 2: totwater < 0 (water table going down): +ELSEIF(totwater.lt.0.)then + + + if(wtd.ge.zsoil(nsoil))then !wtd in the resolved layers + + do k=nsoil-1,1,-1 + if(wtd.lt.zsoil(k))exit + enddo + iwtd=k + + k1=iwtd+1 + do kwtd=k1,nsoil + +!max water that the layer can yield + maxwatdw=dzs(kwtd)*(smc(kwtd)-max(smceq(kwtd),sice(kwtd))) + + if(-totwater.le.maxwatdw)then + smc(kwtd) = smc(kwtd) + totwater / dzs(kwtd) + if(smc(kwtd).gt.smceq(kwtd))then + wtd = ( smc(kwtd)*dzs(kwtd) & + - smceq(kwtd)*zsoil(iwtd) + smcmax*zsoil(kwtd) ) / & + ( smcmax-smceq(kwtd) ) + else + wtd=zsoil(kwtd) + iwtd=iwtd+1 + endif + totwater=0. + exit + else + wtd = zsoil(kwtd) + iwtd=iwtd+1 + if(maxwatdw.ge.0.)then + smc(kwtd) = smc(kwtd) + maxwatdw / dzs(kwtd) + totwater = totwater + maxwatdw + endif + endif + + enddo + + if(iwtd.eq.nsoil.and.totwater.lt.0.)then + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + maxwatdw=dzs(nsoil)*(smcwtd-smceqdeep) + + if(-totwater.le.maxwatdw)then + + smcwtd = smcwtd + totwater / dzs(nsoil) + wtd = max( ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) , zsoil(nsoil)-dzs(nsoil) ) + + else + + wtd=zsoil(nsoil)-dzs(nsoil) + smcwtd = smcwtd + totwater / dzs(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzs(nsoil)/(smcmax-smceqdeep) + wtd=wtd-dzup + smcwtd=smceqdeep + + endif + + endif + + + + elseif(wtd.ge.zsoil(nsoil)-dzs(nsoil))then + +!if wtd was already below the bottom of the resolved soil crust + !gmmequilibrium soil moisture content + smceqdeep = smcmax * ( psisat / & + (psisat - dzs(nsoil)) ) ** (1./bexp) +! smceqdeep = max(smceqdeep,smcwlt) + smceqdeep = max(smceqdeep,1.E-4) + + maxwatdw=dzs(nsoil)*(smcwtd-smceqdeep) + + if(-totwater.le.maxwatdw)then + + smcwtd = smcwtd + totwater / dzs(nsoil) + wtd = max( ( smcwtd*dzs(nsoil) & + - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / & + ( smcmax-smceqdeep ) , zsoil(nsoil)-dzs(nsoil) ) + + else + + wtd=zsoil(nsoil)-dzs(nsoil) + smcwtd = smcwtd + totwater / dzs(nsoil) +!and now even further down + dzup=(smceqdeep-smcwtd)*dzs(nsoil)/(smcmax-smceqdeep) + wtd=wtd-dzup + smcwtd=smceqdeep + + endif + + else +!gmmequilibrium soil moisture content + wgpmid = smcmax * ( psisat / & + (psisat - (zsoil(nsoil)-wtd)) ) ** (1./bexp) +! wgpmid=max(wgpmid,smcwlt) + wgpmid=max(wgpmid,1.E-4) + syielddw=smcmax-wgpmid + wtdold=wtd + wtd = wtdold + totwater/syielddw +!update wtdwgp + smcwtd = (smcwtd*(zsoil(nsoil)-wtdold)+wgpmid*(wtdold-wtd) ) / (zsoil(nsoil)-wtd) + + endif + + qspring=0. + +ENDIF + + SH2O = SMC - SICE + + + end subroutine UPDATEWTD + +! ---------------------------------------------------------------------- + +END MODULE GroundWaterMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterTopModelMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterTopModelMod.F90 new file mode 100644 index 0000000000..5e67f648b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/GroundWaterTopModelMod.F90 @@ -0,0 +1,216 @@ +module GroundWaterTopModelMod + +!!! Compute groundwater flow and subsurface runoff based on TOPMODEL (Niu et al., 2007) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine GroundWaterTopModel(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GROUNDWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + integer :: IndUnsatSoil ! layer index of the first unsaturated layer + real(kind=8) :: SatDegUnsatSoil ! degree of saturation of IndUnsatSoil layer + real(kind=kind_noahmp) :: SoilMatPotFrz ! soil matric potential (frozen effects) [mm] + real(kind=kind_noahmp) :: AquiferWatConduct ! aquifer hydraulic conductivity [mm/s] + real(kind=kind_noahmp) :: WaterHeadTbl ! water head at water table [mm] + real(kind=kind_noahmp) :: WaterHead ! water head at layer above water table [mm] + real(kind=kind_noahmp) :: WaterFillPore ! water used to fill air pore [mm] + real(kind=kind_noahmp) :: WatConductAcc ! sum of SoilWatConductTmp*ThicknessSoil + real(kind=kind_noahmp) :: SoilMoistureMin ! minimum soil moisture [m3/m3] + real(kind=kind_noahmp) :: WaterExcessSat ! excessive water above saturation [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: ThicknessSoil ! layer thickness [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSoilMid ! node depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqTmp ! liquid water mass [kg/m2 or mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilEffPorosity ! soil effective porosity + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatConductTmp ! hydraulic conductivity [mm/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoisture ! total soil water content [m3/m3] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth of soil layer-bottom [m] + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! in, maximum soil imperviousness fraction + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! in, soil hydraulic conductivity [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + GridTopoIndex => noahmp%water%param%GridTopoIndex ,& ! in, gridcell mean topgraphic index (global mean) + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SpecYieldGw => noahmp%water%param%SpecYieldGw ,& ! in, specific yield [-], default:0.2 + MicroPoreContent => noahmp%water%param%MicroPoreContent ,& ! in, microprore content (0.0-1.0), default:0.2 + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat ,& ! in, saturated soil hydraulic conductivity [m/s] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! inout, water table depth [m] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! inout, water storage in aquifer [mm] + WaterStorageSoilAqf => noahmp%water%state%WaterStorageSoilAqf ,& ! inout, water storage in aquifer + saturated soil [mm] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! inout, runoff decay factor (1/m) + BaseflowCoeff => noahmp%water%param%BaseflowCoeff ,& ! inout, baseflow coefficient [mm/s] + RechargeGw => noahmp%water%flux%RechargeGw ,& ! out, groundwater recharge rate [mm/s] + DischargeGw => noahmp%water%flux%DischargeGw & ! out, groundwater discharge rate [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSoilMid) ) allocate(DepthSoilMid (1:NumSoilLayer)) + if (.not. allocated(ThicknessSoil) ) allocate(ThicknessSoil (1:NumSoilLayer)) + if (.not. allocated(SoilLiqTmp) ) allocate(SoilLiqTmp (1:NumSoilLayer)) + if (.not. allocated(SoilEffPorosity) ) allocate(SoilEffPorosity (1:NumSoilLayer)) + if (.not. allocated(SoilWatConductTmp)) allocate(SoilWatConductTmp(1:NumSoilLayer)) + if (.not. allocated(SoilMoisture) ) allocate(SoilMoisture (1:NumSoilLayer)) + DepthSoilMid = 0.0 + ThicknessSoil = 0.0 + SoilLiqTmp = 0.0 + SoilEffPorosity = 0.0 + SoilWatConductTmp = 0.0 + SoilMoisture = 0.0 + DischargeGw = 0.0 + RechargeGw = 0.0 + + ! Derive layer-bottom depth in [mm]; KWM:Derive layer thickness in mm + ThicknessSoil(1) = -DepthSoilLayer(1) * 1.0e3 + do LoopInd = 2, NumSoilLayer + ThicknessSoil(LoopInd) = 1.0e3 * (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + enddo + + ! Derive node (middle) depth in [m]; KWM: Positive number, depth below ground surface in m + DepthSoilMid(1) = -DepthSoilLayer(1) / 2.0 + do LoopInd = 2, NumSoilLayer + DepthSoilMid(LoopInd) = -DepthSoilLayer(LoopInd-1) + & + 0.5 * (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + enddo + + ! Convert volumetric soil moisture to mass + do LoopInd = 1, NumSoilLayer + SoilMoisture(LoopInd) = SoilLiqWater(LoopInd) + SoilIce(LoopInd) + SoilLiqTmp(LoopInd) = SoilLiqWater(LoopInd) * ThicknessSoil(LoopInd) + SoilEffPorosity(LoopInd) = max(0.01, SoilMoistureSat(LoopInd)-SoilIce(LoopInd)) + SoilWatConductTmp(LoopInd) = 1.0e3 * SoilWatConductivity(LoopInd) + enddo + + ! The layer index of the first unsaturated layer (the layer right above the water table) + IndUnsatSoil = NumSoilLayer + do LoopInd = 2, NumSoilLayer + if ( WaterTableDepth <= -DepthSoilLayer(LoopInd) ) then + IndUnsatSoil = LoopInd - 1 + exit + endif + enddo + + ! Groundwater discharge [mm/s] + !RunoffDecayFac = 6.0 + !BaseflowCoeff = 5.0 + !DischargeGw = (1.0 - SoilImpervFracMax) * BaseflowCoeff * & + ! exp(-GridTopoIndex) * exp(-RunoffDecayFac * (WaterTableDepth-2.0)) + ! Update from GY Niu 2022 + RunoffDecayFac = SoilExpCoeffB(IndUnsatSoil) / 3.0 + BaseflowCoeff = SoilWatConductTmp(IndUnsatSoil) * 1.0e3 * exp(3.0) ! [mm/s] + DischargeGw = (1.0 - SoilImpervFracMax) * BaseflowCoeff * exp(-GridTopoIndex) * & + exp(-RunoffDecayFac * WaterTableDepth) + + ! Matric potential at the layer above the water table + SatDegUnsatSoil = min(1.0, SoilMoisture(IndUnsatSoil)/SoilMoistureSat(IndUnsatSoil)) + SatDegUnsatSoil = max(SatDegUnsatSoil, real(0.01,kind=8)) + SoilMatPotFrz = -SoilMatPotentialSat(IndUnsatSoil) * 1000.0 * & + SatDegUnsatSoil**(-SoilExpCoeffB(IndUnsatSoil)) ! m -> mm + SoilMatPotFrz = max(-120000.0, MicroPoreContent*SoilMatPotFrz) + + ! Recharge rate qin to groundwater + !AquiferWatConduct = SoilWatConductTmp(IndUnsatSoil) + AquiferWatConduct = 2.0 * (SoilWatConductTmp(IndUnsatSoil) * SoilWatConductivitySat(IndUnsatSoil)*1.0e3) / & + (SoilWatConductTmp(IndUnsatSoil) + SoilWatConductivitySat(IndUnsatSoil)*1.0e3) ! harmonic average, GY Niu's update 2022 + WaterHeadTbl = -WaterTableDepth * 1.0e3 !(mm) + WaterHead = SoilMatPotFrz - DepthSoilMid(IndUnsatSoil) * 1.0e3 !(mm) + RechargeGw = -AquiferWatConduct * (WaterHeadTbl - WaterHead) / & + ((WaterTableDepth-DepthSoilMid(IndUnsatSoil)) * 1.0e3) + RechargeGw = max(-10.0/SoilTimeStep, min(10.0/SoilTimeStep, RechargeGw)) + + ! Water storage in the aquifer + saturated soil + WaterStorageSoilAqf = WaterStorageSoilAqf + (RechargeGw - DischargeGw) * SoilTimeStep !(mm) + if ( IndUnsatSoil == NumSoilLayer ) then + WaterStorageAquifer = WaterStorageAquifer + (RechargeGw - DischargeGw) * SoilTimeStep !(mm) + WaterStorageSoilAqf = WaterStorageAquifer + WaterTableDepth = (-DepthSoilLayer(NumSoilLayer) + 25.0) - & + WaterStorageAquifer / 1000.0 / SpecYieldGw !(m) + SoilLiqTmp(NumSoilLayer) = SoilLiqTmp(NumSoilLayer) - RechargeGw * SoilTimeStep ! [mm] + SoilLiqTmp(NumSoilLayer) = SoilLiqTmp(NumSoilLayer) + max(0.0, (WaterStorageAquifer-5000.0)) + WaterStorageAquifer = min(WaterStorageAquifer, 5000.0) + else + if ( IndUnsatSoil == NumSoilLayer-1 ) then + WaterTableDepth = -DepthSoilLayer(NumSoilLayer) - (WaterStorageSoilAqf - SpecYieldGw*1000.0*25.0) / & + (SoilEffPorosity(NumSoilLayer)) / 1000.0 + else + WaterFillPore = 0.0 ! water used to fill soil air pores + do LoopInd = IndUnsatSoil+2, NumSoilLayer + WaterFillPore = WaterFillPore + SoilEffPorosity(LoopInd) * ThicknessSoil(LoopInd) + enddo + WaterTableDepth = -DepthSoilLayer(IndUnsatSoil+1) - (WaterStorageSoilAqf - SpecYieldGw*1000.0*25.0 - & + WaterFillPore) / (SoilEffPorosity(IndUnsatSoil+1)) / 1000.0 + endif + WatConductAcc = 0.0 + do LoopInd = 1, NumSoilLayer + WatConductAcc = WatConductAcc + SoilWatConductTmp(LoopInd) * ThicknessSoil(LoopInd) + enddo + do LoopInd = 1, NumSoilLayer ! Removing subsurface runoff + SoilLiqTmp(LoopInd) = SoilLiqTmp(LoopInd) - DischargeGw * SoilTimeStep * & + SoilWatConductTmp(LoopInd) * ThicknessSoil(LoopInd) / WatConductAcc + enddo + endif + WaterTableDepth = max(1.5, WaterTableDepth) + + ! Limit SoilLiqTmp to be greater than or equal to SoilMoistureMin + ! Get water needed to bring SoilLiqTmp equal SoilMoistureMin from lower layer. + SoilMoistureMin = 0.01 + do LoopInd = 1, NumSoilLayer-1 + if ( SoilLiqTmp(LoopInd) < 0.0 ) then + WaterExcessSat = SoilMoistureMin - SoilLiqTmp(LoopInd) + else + WaterExcessSat = 0.0 + endif + SoilLiqTmp(LoopInd ) = SoilLiqTmp(LoopInd ) + WaterExcessSat + SoilLiqTmp(LoopInd+1) = SoilLiqTmp(LoopInd+1) - WaterExcessSat + enddo + LoopInd = NumSoilLayer + if ( SoilLiqTmp(LoopInd) < SoilMoistureMin ) then + WaterExcessSat = SoilMoistureMin - SoilLiqTmp(LoopInd) + else + WaterExcessSat = 0.0 + endif + SoilLiqTmp(LoopInd) = SoilLiqTmp(LoopInd) + WaterExcessSat + WaterStorageAquifer = WaterStorageAquifer - WaterExcessSat + WaterStorageSoilAqf = WaterStorageSoilAqf - WaterExcessSat + + ! update soil moisture + do LoopInd = 1, NumSoilLayer + SoilLiqWater(LoopInd) = SoilLiqTmp(LoopInd) / ThicknessSoil(LoopInd) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSoilMid ) + deallocate(ThicknessSoil ) + deallocate(SoilLiqTmp ) + deallocate(SoilEffPorosity ) + deallocate(SoilWatConductTmp) + deallocate(SoilMoisture ) + + end associate + + end subroutine GroundWaterTopModel + +end module GroundWaterTopModelMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/HumiditySaturationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/HumiditySaturationMod.F90 new file mode 100644 index 0000000000..8a912d1995 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/HumiditySaturationMod.F90 @@ -0,0 +1,63 @@ +module HumiditySaturationMod + +!!! Compute saturated surface specific humidity and changing rate to temperature + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine HumiditySaturation(TemperatureAir, PressureAir, MixingRatioSat, MixingRatioSatTempD) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CALHUM +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + real(kind=kind_noahmp), intent(in) :: TemperatureAir ! air temperature (K) + real(kind=kind_noahmp), intent(in) :: PressureAir ! air pressure (pa) + real(kind=kind_noahmp), intent(out) :: MixingRatioSat ! saturated mixing ratio (g/g) + real(kind=kind_noahmp), intent(out) :: MixingRatioSatTempD ! d(MixingRatioSat)/d(T) + +! local variable + real(kind=kind_noahmp), parameter :: Const1 = 17.67 ! constant 1 + real(kind=kind_noahmp), parameter :: TemperatureFrz = 273.15 ! freezing temperature 0degC [K] + real(kind=kind_noahmp), parameter :: Const2 = 29.65 ! constant 2 + real(kind=kind_noahmp), parameter :: ConstLatHeatVap = 2.501e6 ! latent heat of vaporization [J/kg] + real(kind=kind_noahmp), parameter :: Const3 = Const1*(TemperatureFrz-Const2) ! constant 3 + real(kind=kind_noahmp), parameter :: VapPresSatFrz = 0.611 ! vapor pressure at 0 degC [Pa] + real(kind=kind_noahmp), parameter :: GasConstWatVap = 461.0 ! specific gas constant for water vapor [J/kg/K] + real(kind=kind_noahmp), parameter :: RatioGasConst = 0.622 ! ratio of gas constant of dry air to water vapor + real(kind=kind_noahmp) :: VapPresSatTemp ! saturated vapor pressure at air temperature [Pa] + real(kind=kind_noahmp) :: PressureAirKpa ! air pressure in KPa unit + +! ---------------------------------------------------------------------- + + ! calculated saturated vapor pressure at air temperature + VapPresSatTemp = VapPresSatFrz * exp(ConstLatHeatVap / GasConstWatVap * & + (1.0/TemperatureFrz - 1.0/TemperatureAir)) + + ! convert PressureAir from Pa to KPa + PressureAirKpa = PressureAir * 1.0e-3 + + ! calculate saturated mixing ratio + MixingRatioSat = RatioGasConst * VapPresSatTemp / (PressureAirKpa - VapPresSatTemp) + + ! convert from g/g to g/kg + MixingRatioSat = MixingRatioSat * 1.0e3 + + ! MixingRatioSatTempD is calculated assuming MixingRatioSat is a specific humidity + MixingRatioSatTempD = (MixingRatioSat / (1+MixingRatioSat)) * Const3 / (TemperatureAir-Const2)**2 + + ! MixingRatioSat needs to be in g/g when returned for surface flux calculation + MixingRatioSat = MixingRatioSat / 1.0e3 + + end subroutine HumiditySaturation + +end module HumiditySaturationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationFloodMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationFloodMod.F90 new file mode 100644 index 0000000000..9ef7b7ad64 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationFloodMod.F90 @@ -0,0 +1,70 @@ +module IrrigationFloodMod + +!!! Estimate irrigation water depth (m) based on surface flooding irrigation method +!!! Reference: chapter 4 of NRCS, Part 623 National Engineering Handbook +!!! Irrigation water is applied on the surface based on present soil moisture and +!!! infiltration rate of the soil. Flooding or overland flow is based on infiltration excess + + use Machine + use NoahmpVarType + use ConstantDefineMod + use IrrigationInfilPhilipMod, only : IrrigationInfilPhilip + + implicit none + +contains + + subroutine IrrigationFlood(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: FLOOD_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: InfilRateSfc ! surface infiltration rate [m/s] + +! -------------------------------------------------------------------- + associate( & + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil time step [s] + NumSoilTimeStep => noahmp%config%domain%NumSoilTimeStep ,& ! in, number of time step for calculating soil processes + IrriFloodRateFac => noahmp%water%param%IrriFloodRateFac ,& ! in, flood application rate factor + IrrigationFracFlood => noahmp%water%state%IrrigationFracFlood ,& ! in, fraction of grid under flood irrigation (0 to 1) + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, flood irrigation water amount [m] + SoilSfcInflowAcc => noahmp%water%flux%SoilSfcInflowAcc ,& ! inout, accumulated water flux into soil during soil timestep [m/s * dt_soil/dt_main] + IrrigationRateFlood => noahmp%water%flux%IrrigationRateFlood & ! inout, flood irrigation water rate [m/timestep] + ) +! ---------------------------------------------------------------------- + + ! initialize local variables + InfilRateSfc = 0.0 + + ! estimate infiltration rate based on Philips Eq. + call IrrigationInfilPhilip(noahmp, SoilTimeStep, InfilRateSfc) + + ! irrigation rate of flood irrigation. It should be + ! greater than infiltration rate to get infiltration + ! excess runoff at the time of application + IrrigationRateFlood = InfilRateSfc * SoilTimeStep * IrriFloodRateFac ! Limit irrigation rate to fac*infiltration rate + IrrigationRateFlood = IrrigationRateFlood * IrrigationFracFlood + + if ( IrrigationRateFlood >= IrrigationAmtFlood ) then + IrrigationRateFlood = IrrigationAmtFlood + IrrigationAmtFlood = 0.0 + else + IrrigationAmtFlood = IrrigationAmtFlood - IrrigationRateFlood + endif + + ! update water flux going to surface soil + SoilSfcInflowAcc = SoilSfcInflowAcc + (IrrigationRateFlood / SoilTimeStep * NumSoilTimeStep) ! [m/s * dt_soil/dt_main] + + end associate + + end subroutine IrrigationFlood + +end module IrrigationFloodMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationInfilPhilipMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationInfilPhilipMod.F90 new file mode 100644 index 0000000000..49ef888463 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationInfilPhilipMod.F90 @@ -0,0 +1,86 @@ +module IrrigationInfilPhilipMod + +!!! Estimate infiltration rate based on Philip's two parameter equation +!!! Reference: Eq.2 in Valiantzas (2010): New linearized two-parameter infiltration equation for direct +!!! determination of conductivity and sorptivity, J. Hydrology. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine IrrigationInfilPhilip(noahmp, TimeStep, InfilRateSfc) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: IRR_PHILIP_INFIL +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! time step [s] + real(kind=kind_noahmp), intent(out) :: InfilRateSfc ! surface infiltration rate [m/s] + +! local variables + integer :: LoopInd ! loop indices + integer :: IndSoilLayer ! soil layer index + real(kind=kind_noahmp) :: SoilSorptivity ! sorptivity [m s^-1/2] + real(kind=kind_noahmp) :: SoilWatConductInit ! intial hydraulic conductivity [m/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilIceMaxTmp ! maximum soil ice content [m3/m3] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialize out-only and local variables + SoilWatConductivity = 0.0 + SoilWatDiffusivity = 0.0 + SoilIceMaxTmp = 0.0 + SoilSorptivity = 0.0 + SoilWatConductInit = 0.0 + + ! maximum ice fraction + do LoopInd = 1, NumSoilLayer + if ( SoilIce(LoopInd) > SoilIceMaxTmp ) SoilIceMaxTmp = SoilIce(LoopInd) + enddo + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + IndSoilLayer = 1 + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilLiqWater(IndSoilLayer), SoilIceMaxTmp, IndSoilLayer) + + ! sorptivity based on Eq. 10b from Kutilek, Miroslav, and Jana Valentova (1986) + ! sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SoilSorptivity = sqrt(2.0 * max(0.0, (SoilMoistureSat(IndSoilLayer) - SoilMoisture(IndSoilLayer))) * & + (SoilWatDiffusivitySat(IndSoilLayer) - SoilWatDiffusivity)) + + ! parameter A in Eq. 9 of Valiantzas (2010) is given by + SoilWatConductInit = min(SoilWatConductivity, (2.0/3.0) * SoilWatConductivitySat(IndSoilLayer)) + SoilWatConductInit = max(SoilWatConductInit , (1.0/3.0) * SoilWatConductivitySat(IndSoilLayer)) + + ! maximun infiltration rate, m/s + InfilRateSfc = 0.5 * SoilSorptivity * (TimeStep**(-0.5)) + SoilWatConductInit ! m/s + InfilRateSfc = max(0.0, InfilRateSfc) + + end associate + + end subroutine IrrigationInfilPhilip + +end module IrrigationInfilPhilipMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationMicroMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationMicroMod.F90 new file mode 100644 index 0000000000..d115e8b359 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationMicroMod.F90 @@ -0,0 +1,73 @@ +module IrrigationMicroMod + +!!! Estimate irrigation water depth (m) based on Micro irrigation method +!!! Reference: chapter 7 of NRCS, Part 623 National Engineering Handbook +!!! Irrigation water is applied under the canopy, within first layer +!!! (at ~5 cm depth) considering current soil moisture + + use Machine + use NoahmpVarType + use ConstantDefineMod + use IrrigationInfilPhilipMod, only : IrrigationInfilPhilip + + implicit none + +contains + + subroutine IrrigationMicro(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: MICRO_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: InfilRateSfc ! surface infiltration rate [m/s] + real(kind=kind_noahmp) :: IrriRateTmp ! temporary micro irrigation rate [m/timestep] + +! -------------------------------------------------------------------- + associate( & + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil time step [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + IrrigationFracMicro => noahmp%water%state%IrrigationFracMicro ,& ! in, fraction of grid under micro irrigation (0 to 1) + IrriMicroRate => noahmp%water%param%IrriMicroRate ,& ! in, micro irrigation rate [mm/hr] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, micro irrigation water amount [m] + IrrigationRateMicro => noahmp%water%flux%IrrigationRateMicro & ! inout, micro irrigation water rate [m/timestep] + ) +! ---------------------------------------------------------------------- + + ! initialize local variables + InfilRateSfc = 0.0 + IrriRateTmp = 0.0 + + ! estimate infiltration rate based on Philips Eq. + call IrrigationInfilPhilip(noahmp, SoilTimeStep, InfilRateSfc) + + ! irrigation rate of micro irrigation + IrriRateTmp = IrriMicroRate * (1.0/1000.0) * SoilTimeStep/ 3600.0 ! NRCS rate/time step - calibratable + IrrigationRateMicro = min(0.5*InfilRateSfc*SoilTimeStep, IrrigationAmtMicro, IrriRateTmp) ! Limit irrigation rate to minimum of 0.5*infiltration rate + ! and to the NRCS recommended rate, (m) + IrrigationRateMicro = IrrigationRateMicro * IrrigationFracMicro + + if ( IrrigationRateMicro >= IrrigationAmtMicro ) then + IrrigationRateMicro = IrrigationAmtMicro + IrrigationAmtMicro = 0.0 + else + IrrigationAmtMicro = IrrigationAmtMicro - IrrigationRateMicro + endif + + ! update soil moisture + ! we implement drip in first layer of the Noah-MP. Change layer 1 moisture wrt to irrigation rate + SoilLiqWater(1) = SoilLiqWater(1) + (IrrigationRateMicro / (-1.0*DepthSoilLayer(1))) + + end associate + + end subroutine IrrigationMicro + +end module IrrigationMicroMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationPrepareMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationPrepareMod.F90 new file mode 100644 index 0000000000..108bbe68d1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationPrepareMod.F90 @@ -0,0 +1,99 @@ +module IrrigationPrepareMod + +!!! Prepare dynamic irrigation variables and trigger irrigation based on conditions + + use Machine + use NoahmpVarType + use ConstantDefineMod + use IrrigationTriggerMod, only : IrrigationTrigger + + implicit none + +contains + + subroutine IrrigationPrepare(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: None (embedded in NOAHMP_SFLX +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + +! ---------------------------------------------------------------------- + associate( & + LandUseDataName => noahmp%config%domain%LandUseDataName ,& ! in, landuse data name (USGS or MODIS_IGBP) + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to calculate soil processes + OptIrrigationMethod => noahmp%config%nmlist%OptIrrigationMethod ,& ! in, irrigation method option + IrriFracThreshold => noahmp%water%param%IrriFracThreshold ,& ! in, irrigation fraction threshold + IrriStopPrecipThr => noahmp%water%param%IrriStopPrecipThr ,& ! in, maximum precipitation to stop irrigation trigger + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, total input irrigation fraction of a grid + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] to be applied, Sprinkler + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, flood irrigation water amount [m] + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, micro irrigation water amount [m] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! inout, rainfall [mm/s] at reference height + FlagCropland => noahmp%config%domain%FlagCropland ,& ! out, flag to identify croplands + IrrigationFracSprinkler => noahmp%water%state%IrrigationFracSprinkler ,& ! out, sprinkler irrigation fraction (0 to 1) + IrrigationFracMicro => noahmp%water%state%IrrigationFracMicro ,& ! out, fraction of grid under micro irrigation (0 to 1) + IrrigationFracFlood => noahmp%water%state%IrrigationFracFlood & ! out, fraction of grid under flood irrigation (0 to 1) + ) +! ---------------------------------------------------------------------- + + ! initialize + FlagCropland = .false. + + ! determine cropland + if ( trim(LandUseDataName) == "USGS" ) then + if ( (VegType >= 3) .and. (VegType <= 6) ) FlagCropland = .true. + elseif ( trim(LandUseDataName) == "MODIFIED_IGBP_MODIS_NOAH") then + if ( (VegType == 12) .or. (VegType == 14) ) FlagCropland = .true. + endif + + ! if OptIrrigationMethod = 0 and if methods are unknown for certain area, then use sprinkler irrigation method + if ( (OptIrrigationMethod == 0) .and. (IrrigationFracSprinkler == 0.0) .and. (IrrigationFracMicro == 0.0) & + .and. (IrrigationFracFlood == 0.0) .and. (IrrigationFracGrid >= IrriFracThreshold) ) then + IrrigationFracSprinkler = 1.0 + endif + + ! choose method based on user namelist choice + if ( OptIrrigationMethod == 1 ) then + IrrigationFracSprinkler = 1.0 + IrrigationFracMicro = 0.0 + IrrigationFracFlood = 0.0 + elseif ( OptIrrigationMethod == 2 ) then + IrrigationFracSprinkler = 0.0 + IrrigationFracMicro = 1.0 + IrrigationFracFlood = 0.0 + elseif ( OptIrrigationMethod == 3 ) then + IrrigationFracSprinkler = 0.0 + IrrigationFracMicro = 0.0 + IrrigationFracFlood = 1.0 + endif + + ! trigger irrigation only at soil water timestep to be consistent for solving soil water + if ( FlagSoilProcess .eqv. .true. ) then + if ( (FlagCropland .eqv. .true.) .and. (IrrigationFracGrid >= IrriFracThreshold) .and. & + (RainfallRefHeight < (IrriStopPrecipThr/3600.0)) .and. & + ((IrrigationAmtSprinkler+IrrigationAmtMicro+IrrigationAmtFlood) == 0.0) ) then + call IrrigationTrigger(noahmp) + endif + + ! set irrigation off if larger than IrriStopPrecipThr mm/h for this time step and irr triggered last time step + if ( (RainfallRefHeight >= (IrriStopPrecipThr/3600.0)) .or. (IrrigationFracGrid < IrriFracThreshold) ) then + IrrigationAmtSprinkler = 0.0 + IrrigationAmtMicro = 0.0 + IrrigationAmtFlood = 0.0 + endif + endif + + end associate + + end subroutine IrrigationPrepare + +end module IrrigationPrepareMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationSprinklerMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationSprinklerMod.F90 new file mode 100644 index 0000000000..b5dc0eae9b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationSprinklerMod.F90 @@ -0,0 +1,109 @@ +module IrrigationSprinklerMod + +!!! Estimate irrigation water depth (m) based on sprinkler method +!!! Reference: chapter 11 of NRCS, Part 623 National Engineering Handbook. +!!! Irrigation water will be applied over the canopy, affecting present soil moisture, +!!! infiltration rate of the soil, and evaporative loss, which should be executed before canopy process. + + use Machine + use CheckNanMod + use NoahmpVarType + use ConstantDefineMod + use IrrigationInfilPhilipMod, only : IrrigationInfilPhilip + + implicit none + +contains + + subroutine IrrigationSprinkler(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SPRINKLER_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + logical :: FlagNan ! NaN value flag: if NaN, return true + real(kind=kind_noahmp) :: InfilRateSfc ! surface infiltration rate [m/s] + real(kind=kind_noahmp) :: IrriRateTmp ! temporary irrigation rate [m/timestep] + real(kind=kind_noahmp) :: WindSpdTot ! total wind speed [m/s] + real(kind=kind_noahmp) :: IrriLossTmp ! temporary irrigation water loss [%] + real(kind=kind_noahmp) :: PressureVaporSat ! satuarated vapor pressure [Pa] + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] + IrriSprinklerRate => noahmp%water%param%IrriSprinklerRate ,& ! in, sprinkler irrigation rate [mm/h] + IrrigationFracSprinkler => noahmp%water%state%IrrigationFracSprinkler ,& ! in, sprinkler irrigation fraction (0 to 1) + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + HeatLatentIrriEvap => noahmp%energy%flux%HeatLatentIrriEvap ,& ! inout, latent heating due to sprinkler evaporation [W/m2] + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] to be applied, Sprinkler + EvapIrriSprinkler => noahmp%water%flux%EvapIrriSprinkler ,& ! inout, evaporation of irrigation water, sprinkler [mm/s] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! inout, rainfall [mm/s] at reference height + IrrigationRateSprinkler => noahmp%water%flux%IrrigationRateSprinkler ,& ! inout, rate of irrigation by sprinkler [m/timestep] + IrriEvapLossSprinkler => noahmp%water%flux%IrriEvapLossSprinkler ,& ! inout, loss of irrigation water to evaporation,sprinkler [m/timestep] + SoilIce => noahmp%water%state%SoilIce & ! out, soil ice content [m3/m3] + ) +! ---------------------------------------------------------------------- + + ! initialize + SoilIce(:) = max(0.0, SoilMoisture(:)-SoilLiqWater(:)) + + ! estimate infiltration rate based on Philips Eq. + call IrrigationInfilPhilip(noahmp, MainTimeStep, InfilRateSfc) + + ! irrigation rate of sprinkler + IrriRateTmp = IrriSprinklerRate * (1.0/1000.0) * MainTimeStep / 3600.0 ! NRCS rate/time step - calibratable + IrrigationRateSprinkler = min(InfilRateSfc*MainTimeStep, IrrigationAmtSprinkler, IrriRateTmp) ! Limit irrigation rate to minimum of infiltration rate + ! and to the NRCS recommended rate + ! evaporative loss from droplets: Based on Bavi et al., (2009). Evaporation + ! losses from sprinkler irrigation systems under various operating + ! conditions. Journal of Applied Sciences, 9(3), 597-600. + WindSpdTot = sqrt((WindEastwardRefHeight**2.0) + (WindNorthwardRefHeight**2.0)) + PressureVaporSat = 610.8 * exp((17.27*(TemperatureAirRefHeight-273.15)) / (237.3+(TemperatureAirRefHeight-273.15))) + + if ( TemperatureAirRefHeight > 273.15 ) then ! Equation (3) + IrriLossTmp = 4.375 * (exp(0.106*WindSpdTot)) * (((PressureVaporSat-PressureVaporRefHeight)*0.01)**(-0.092)) * & + ((TemperatureAirRefHeight-273.15)**(-0.102)) + else ! Equation (4) + IrriLossTmp = 4.337 * (exp(0.077*WindSpdTot)) * (((PressureVaporSat-PressureVaporRefHeight)*0.01)**(-0.098)) + endif + ! Old PGI Fortran compiler does not support ISNAN function + call CheckRealNaN(IrriLossTmp, FlagNan) + if ( FlagNan .eqv. .true. ) IrriLossTmp = 4.0 ! In case if IrriLossTmp is NaN + if ( (IrriLossTmp > 100.0) .or. (IrriLossTmp < 0.0) ) IrriLossTmp = 4.0 ! In case if IrriLossTmp is out of range + + ! Sprinkler water [m] for sprinkler fraction + IrrigationRateSprinkler = IrrigationRateSprinkler * IrrigationFracSprinkler + if ( IrrigationRateSprinkler >= IrrigationAmtSprinkler ) then + IrrigationRateSprinkler = IrrigationAmtSprinkler + IrrigationAmtSprinkler = 0.0 + else + IrrigationAmtSprinkler = IrrigationAmtSprinkler - IrrigationRateSprinkler + endif + + IrriEvapLossSprinkler = IrrigationRateSprinkler * IrriLossTmp * (1.0/100.0) + IrrigationRateSprinkler = IrrigationRateSprinkler - IrriEvapLossSprinkler + + ! include sprinkler water to total rain for canopy process later + RainfallRefHeight = RainfallRefHeight + (IrrigationRateSprinkler * 1000.0 / MainTimeStep) + + ! cooling and humidification due to sprinkler evaporation, per m^2 calculation + HeatLatentIrriEvap = IrriEvapLossSprinkler * 1000.0 * ConstLatHeatEvap / MainTimeStep ! heat used for evaporation [W/m2] + EvapIrriSprinkler = IrriEvapLossSprinkler * 1000.0 / MainTimeStep ! sprinkler evaporation [mm/s] + + end associate + + end subroutine IrrigationSprinkler + +end module IrrigationSprinklerMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/IrrigationTriggerMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationTriggerMod.F90 new file mode 100644 index 0000000000..b0b96b709b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/IrrigationTriggerMod.F90 @@ -0,0 +1,144 @@ +module IrrigationTriggerMod + +!!! Trigger irrigation if soil moisture less than the management allowable deficit (MAD) +!!! and estimate irrigation water depth [m] using current rootzone soil moisture and field +!!! capacity. There are two options here to trigger the irrigation scheme based on MAD +!!! OptIrrigation = 1 -> if irrigated fraction > threshold fraction +!!! OptIrrigation = 2 -> if irrigated fraction > threshold fraction and within crop season +!!! OptIrrigation = 3 -> if irrigated fraction > threshold fraction and LeafAreaIndex > threshold LeafAreaIndex + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine IrrigationTrigger(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TRIGGER_IRRIGATION +! Original code: P. Valayamkunnath (NCAR) (08/06/2020) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + logical :: FlagIrri ! flag for irrigation activation + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: SoilMoistAvail ! available soil moisture [m] at timestep + real(kind=kind_noahmp) :: SoilMoistAvailMax ! maximum available moisture [m] + real(kind=kind_noahmp) :: IrrigationWater ! irrigation water amount [m] + +! -------------------------------------------------------------------- + associate( & + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + DayJulianInYear => noahmp%config%domain%DayJulianInYear ,& ! in, Julian day of the year + OptIrrigation => noahmp%config%nmlist%OptIrrigation ,& ! in, irrigation option + OptIrrigationMethod => noahmp%config%nmlist%OptIrrigationMethod ,& ! in, irrigation method option + DatePlanting => noahmp%biochem%param%DatePlanting ,& ! in, Planting day (day of year) + DateHarvest => noahmp%biochem%param%DateHarvest ,& ! in, Harvest date (day of year) + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) (m3/m3) + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + IrriStopDayBfHarvest => noahmp%water%param%IrriStopDayBfHarvest ,& ! in, number of days before harvest date to stop irrigation + IrriTriggerLaiMin => noahmp%water%param%IrriTriggerLaiMin ,& ! in, minimum lai to trigger irrigation + SoilWatDeficitAllow => noahmp%water%param%SoilWatDeficitAllow ,& ! in, management allowable deficit (0-1) + IrriFloodLossFrac => noahmp%water%param%IrriFloodLossFrac ,& ! in, factor of flood irrigation loss + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! in, leaf area index [m2/m2] + IrrigationFracGrid => noahmp%water%state%IrrigationFracGrid ,& ! in, irrigated area fraction of a grid + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + IrrigationFracMicro => noahmp%water%state%IrrigationFracMicro ,& ! in, fraction of grid under micro irrigation (0 to 1) + IrrigationFracFlood => noahmp%water%state%IrrigationFracFlood ,& ! in, fraction of grid under flood irrigation (0 to 1) + IrrigationFracSprinkler => noahmp%water%state%IrrigationFracSprinkler ,& ! in, sprinkler irrigation fraction (0 to 1) + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, irrigation water amount [m] to be applied, Micro + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, irrigation water amount [m] to be applied, Flood + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] to be applied, Sprinkler + IrrigationCntSprinkler => noahmp%water%state%IrrigationCntSprinkler ,& ! inout, irrigation event number, Sprinkler + IrrigationCntMicro => noahmp%water%state%IrrigationCntMicro ,& ! inout, irrigation event number, Micro + IrrigationCntFlood => noahmp%water%state%IrrigationCntFlood & ! inout, irrigation event number, Flood + ) +! ---------------------------------------------------------------------- + + FlagIrri = .true. + + ! check if irrigation is can be activated or not + if ( OptIrrigation == 2 ) then ! activate irrigation if within crop season + if ( (DayJulianInYear < DatePlanting) .or. (DayJulianInYear > (DateHarvest-IrriStopDayBfHarvest)) ) & + FlagIrri = .false. + elseif ( OptIrrigation == 3) then ! activate if LeafAreaIndex > threshold LeafAreaIndex + if ( LeafAreaIndex < IrriTriggerLaiMin) FlagIrri = .false. + elseif ( (OptIrrigation > 3) .or. (OptIrrigation < 1) ) then + FlagIrri = .false. + endif + + if ( FlagIrri .eqv. .true. ) then + ! estimate available water and field capacity for the root zone + SoilMoistAvail = 0.0 + SoilMoistAvailMax = 0.0 + SoilMoistAvail = (SoilLiqWater(1) - SoilMoistureWilt(1)) * (-1.0) * DepthSoilLayer(1) ! current soil water (m) + SoilMoistAvailMax = (SoilMoistureFieldCap(1) - SoilMoistureWilt(1)) * (-1.0) * DepthSoilLayer(1) ! available water (m) + do LoopInd = 2, NumSoilLayerRoot + SoilMoistAvail = SoilMoistAvail + (SoilLiqWater(LoopInd) - SoilMoistureWilt(LoopInd)) * & + (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + SoilMoistAvailMax = SoilMoistAvailMax + (SoilMoistureFieldCap(LoopInd) - SoilMoistureWilt(LoopInd)) * & + (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + enddo + + ! check if root zone soil moisture < SoilWatDeficitAllow (calibratable) + if ( (SoilMoistAvail/SoilMoistAvailMax) <= SoilWatDeficitAllow ) then + ! amount of water need to be added to bring soil moisture back to + ! field capacity, i.e., irrigation water amount (m) + IrrigationWater = (SoilMoistAvailMax - SoilMoistAvail) * IrrigationFracGrid * VegFrac + + ! sprinkler irrigation amount (m) based on 2D IrrigationFracSprinkler + if ( (IrrigationAmtSprinkler == 0.0) .and. (IrrigationFracSprinkler > 0.0) .and. (OptIrrigationMethod == 0) ) then + IrrigationAmtSprinkler = IrrigationFracSprinkler * IrrigationWater + IrrigationCntSprinkler = IrrigationCntSprinkler + 1 + ! sprinkler irrigation amount (m) based on namelist choice + elseif ( (IrrigationAmtSprinkler == 0.0) .and. (OptIrrigationMethod == 1) ) then + IrrigationAmtSprinkler = IrrigationWater + IrrigationCntSprinkler = IrrigationCntSprinkler + 1 + endif + + ! micro irrigation amount (m) based on 2D IrrigationFracMicro + if ( (IrrigationAmtMicro == 0.0) .and. (IrrigationFracMicro > 0.0) .and. (OptIrrigationMethod == 0) ) then + IrrigationAmtMicro = IrrigationFracMicro * IrrigationWater + IrrigationCntMicro = IrrigationCntMicro + 1 + ! micro irrigation amount (m) based on namelist choice + elseif ( (IrrigationAmtMicro == 0.0) .and. (OptIrrigationMethod == 2) ) then + IrrigationAmtMicro = IrrigationWater + IrrigationCntMicro = IrrigationCntMicro + 1 + endif + + ! flood irrigation amount (m): Assumed to saturate top two layers and + ! third layer to FC. As water moves from one end of the field to + ! another, surface layers will be saturated. + ! flood irrigation amount (m) based on 2D IrrigationFracFlood + if ( (IrrigationAmtFlood == 0.0) .and. (IrrigationFracFlood > 0.0) .and. (OptIrrigationMethod == 0) ) then + IrrigationAmtFlood = IrrigationFracFlood * IrrigationWater * (1.0/(1.0 - IrriFloodLossFrac)) + IrrigationCntFlood = IrrigationCntFlood + 1 + !flood irrigation amount (m) based on namelist choice + elseif ( (IrrigationAmtFlood == 0.0) .and. (OptIrrigationMethod == 3) ) then + IrrigationAmtFlood = IrrigationWater * (1.0/(1.0 - IrriFloodLossFrac)) + IrrigationCntFlood = IrrigationCntFlood + 1 + endif + else + IrrigationWater = 0.0 + IrrigationAmtSprinkler = 0.0 + IrrigationAmtMicro = 0.0 + IrrigationAmtFlood = 0.0 + endif + + endif + + end associate + + end subroutine IrrigationTrigger + +end module IrrigationTriggerMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/Makefile b/src/core_atmosphere/physics/physics_noahmp/src/Makefile new file mode 100644 index 0000000000..675bdf9dff --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/Makefile @@ -0,0 +1,351 @@ +.SUFFIXES: .F90 .o + +.PHONY: src src_lib + +# +# The Noah-MP code fails to build with the GNU compilers with -std=f2008, +# so remove that flag here if it is present in FFLAGS +# +FFLAGS_NONSTD = $(shell printf "%s" "$(FFLAGS)" | sed -e 's/-std=f2008//g' ) + +all: dummy src + +dummy: + echo "****** compiling physics_noahmp/utility ******" + +OBJS = ConstantDefineMod.o \ + ConfigVarType.o \ + ForcingVarType.o \ + EnergyVarType.o \ + WaterVarType.o \ + BiochemVarType.o \ + NoahmpVarType.o \ + ConfigVarInitMod.o \ + ForcingVarInitMod.o \ + EnergyVarInitMod.o \ + WaterVarInitMod.o \ + BiochemVarInitMod.o \ + CanopyHydrologyMod.o \ + GroundWaterTopModelMod.o \ + IrrigationFloodMod.o \ + IrrigationInfilPhilipMod.o \ + IrrigationMicroMod.o \ + MatrixSolverTriDiagonalMod.o \ + RunoffSubSurfaceDrainageMod.o \ + RunoffSubSurfaceEquiWaterTableMod.o \ + RunoffSubSurfaceGroundWaterMod.o \ + RunoffSubSurfaceShallowMmfMod.o \ + RunoffSurfaceBatsMod.o \ + RunoffSurfaceDynamicVicMod.o \ + RunoffSurfaceExcessDynamicVicMod.o \ + RunoffSurfaceFreeDrainMod.o \ + RunoffSurfaceTopModelEquiMod.o \ + RunoffSurfaceTopModelGrdMod.o \ + RunoffSurfaceTopModelMmfMod.o \ + RunoffSurfaceVicMod.o \ + RunoffSurfaceXinAnJiangMod.o \ + ShallowWaterTableMmfMod.o \ + SnowfallBelowCanopyMod.o \ + SnowLayerCombineMod.o \ + SnowLayerDivideMod.o \ + SnowLayerWaterComboMod.o \ + SnowpackCompactionMod.o \ + SnowpackHydrologyMod.o \ + SnowWaterMainMod.o \ + SoilHydraulicPropertyMod.o \ + SoilMoistureSolverMod.o \ + SoilWaterDiffusionRichardsMod.o \ + SoilWaterInfilGreenAmptMod.o \ + SoilWaterInfilPhilipMod.o \ + SoilWaterInfilSmithParlangeMod.o \ + SoilWaterMainMod.o \ + TileDrainageEquiDepthMod.o \ + TileDrainageHooghoudtMod.o \ + TileDrainageSimpleMod.o \ + WaterMainMod.o \ + WaterTableDepthSearchMod.o \ + WaterTableEquilibriumMod.o \ + IrrigationTriggerMod.o \ + IrrigationSprinklerMod.o \ + CanopyWaterInterceptMod.o \ + PrecipitationHeatAdvectMod.o \ + SnowThermalPropertyMod.o \ + SoilThermalPropertyMod.o \ + GroundThermalPropertyMod.o \ + EnergyMainMod.o \ + NoahmpMainMod.o \ + SnowAgingBatsMod.o \ + SnowAlbedoBatsMod.o \ + SnowAlbedoClassMod.o \ + GroundAlbedoMod.o \ + CanopyRadiationTwoStreamMod.o \ + SurfaceAlbedoMod.o \ + SurfaceRadiationMod.o \ + HumiditySaturationMod.o \ + ResistanceAboveCanopyChen97Mod.o \ + ResistanceAboveCanopyMostMod.o \ + ResistanceCanopyStomataBallBerryMod.o \ + ResistanceCanopyStomataJarvisMod.o \ + ResistanceLeafToGroundMod.o \ + VaporPressureSaturationMod.o \ + SurfaceEnergyFluxVegetatedMod.o \ + ResistanceBareGroundChen97Mod.o \ + ResistanceBareGroundMostMod.o \ + SurfaceEnergyFluxBareGroundMod.o \ + SoilSnowTemperatureMainMod.o \ + SoilSnowTemperatureSolverMod.o \ + SoilSnowThermalDiffusionMod.o \ + SoilSnowWaterPhaseChangeMod.o \ + SoilWaterSupercoolKoren99Mod.o \ + SoilWaterSupercoolNiu06Mod.o \ + SnowCoverGroundNiu07Mod.o \ + GroundRoughnessPropertyMod.o \ + SurfaceEmissivityMod.o \ + PsychrometricVariableMod.o \ + ResistanceGroundEvaporationMod.o \ + SoilWaterTranspirationMod.o \ + AtmosForcingMod.o \ + PhenologyMainMod.o \ + BiochemCropMainMod.o \ + BiochemNatureVegMainMod.o \ + CarbonFluxCropMod.o \ + CarbonFluxNatureVegMod.o \ + CropGrowDegreeDayMod.o \ + CropPhotosynthesisMod.o \ + IrrigationPrepareMod.o \ + BalanceErrorCheckMod.o \ + GeneralInitMod.o \ + BalanceErrorCheckGlacierMod.o \ + EnergyMainGlacierMod.o \ + GeneralInitGlacierMod.o \ + GlacierIceThermalPropertyMod.o \ + GlacierPhaseChangeMod.o \ + GlacierTemperatureMainMod.o \ + GlacierTemperatureSolverMod.o \ + GlacierThermalDiffusionMod.o \ + GroundAlbedoGlacierMod.o \ + GroundRoughnessPropertyGlacierMod.o \ + GroundThermalPropertyGlacierMod.o \ + NoahmpMainGlacierMod.o \ + PrecipitationHeatAdvectGlacierMod.o \ + PsychrometricVariableGlacierMod.o \ + ResistanceGroundEvaporationGlacierMod.o \ + SnowCoverGlacierMod.o \ + SnowWaterMainGlacierMod.o \ + SnowpackHydrologyGlacierMod.o \ + SurfaceAlbedoGlacierMod.o \ + SurfaceEmissivityGlacierMod.o \ + SurfaceEnergyFluxGlacierMod.o \ + SurfaceRadiationGlacierMod.o \ + WaterMainGlacierMod.o + +src: $(OBJS) + +src_lib: + ar -ru ./../../libphys.a $(OBJS) + +# DEPENDENCIES: + +ConstantDefineMod.o: ../utility/Machine.o +ConfigVarType.o: ../utility/Machine.o +ForcingVarType.o: ../utility/Machine.o +EnergyVarType.o: ../utility/Machine.o +WaterVarType.o: ../utility/Machine.o +BiochemVarType.o: ../utility/Machine.o +NoahmpVarType.o: ConfigVarType.o ForcingVarType.o EnergyVarType.o \ + WaterVarType.o BiochemVarType.o +ConfigVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +ForcingVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +EnergyVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +WaterVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +BiochemVarInitMod.o: ../utility/Machine.o NoahmpVarType.o +CanopyHydrologyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundWaterTopModelMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +IrrigationFloodMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + IrrigationInfilPhilipMod.o +IrrigationInfilPhilipMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +IrrigationMicroMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + IrrigationInfilPhilipMod.o +MatrixSolverTriDiagonalMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSubSurfaceDrainageMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSubSurfaceEquiWaterTableMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + WaterTableEquilibriumMod.o +RunoffSubSurfaceGroundWaterMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + GroundWaterTopModelMod.o +RunoffSubSurfaceShallowMmfMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + ShallowWaterTableMmfMod.o +RunoffSurfaceBatsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceDynamicVicMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilWaterInfilPhilipMod.o RunoffSurfaceExcessDynamicVicMod.o \ + SoilWaterInfilSmithParlangeMod.o SoilWaterInfilGreenAmptMod.o +RunoffSurfaceExcessDynamicVicMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceFreeDrainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +RunoffSurfaceTopModelEquiMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceTopModelGrdMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceTopModelMmfMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceVicMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +RunoffSurfaceXinAnJiangMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ShallowWaterTableMmfMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowfallBelowCanopyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowLayerCombineMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowLayerWaterComboMod.o +SnowLayerDivideMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowLayerWaterComboMod.o +SnowLayerWaterComboMod.o: ../utility/Machine.o ConstantDefineMod.o +SnowpackCompactionMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowpackHydrologyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowLayerCombineMod.o +SnowWaterMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowfallBelowCanopyMod.o SnowpackCompactionMod.o SnowLayerDivideMod.o \ + SnowLayerCombineMod.o SnowpackHydrologyMod.o +SoilHydraulicPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilMoistureSolverMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + MatrixSolverTriDiagonalMod.o +SoilWaterDiffusionRichardsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterInfilGreenAmptMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterInfilPhilipMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterInfilSmithParlangeMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilHydraulicPropertyMod.o +SoilWaterMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + RunoffSurfaceTopModelGrdMod.o RunoffSurfaceTopModelEquiMod.o \ + RunoffSurfaceFreeDrainMod.o RunoffSurfaceBatsMod.o \ + RunoffSurfaceTopModelMmfMod.o RunoffSurfaceVicMod.o \ + RunoffSurfaceXinAnJiangMod.o RunoffSurfaceDynamicVicMod.o \ + RunoffSubSurfaceEquiWaterTableMod.o RunoffSubSurfaceGroundWaterMod.o \ + RunoffSubSurfaceDrainageMod.o RunoffSubSurfaceShallowMmfMod.o \ + SoilWaterDiffusionRichardsMod.o SoilMoistureSolverMod.o \ + TileDrainageSimpleMod.o TileDrainageHooghoudtMod.o +TileDrainageEquiDepthMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +TileDrainageHooghoudtMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + TileDrainageEquiDepthMod.o WaterTableDepthSearchMod.o \ + WaterTableEquilibriumMod.o +TileDrainageSimpleMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +WaterMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + CanopyHydrologyMod.o SnowWaterMainMod.o IrrigationFloodMod.o \ + IrrigationMicroMod.o SoilWaterMainMod.o +WaterTableDepthSearchMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +WaterTableEquilibriumMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +IrrigationTriggerMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +IrrigationSprinklerMod.o: ../utility/Machine.o ../utility/CheckNanMod.o \ + NoahmpVarType.o ConstantDefineMod.o IrrigationInfilPhilipMod.o +CanopyWaterInterceptMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PrecipitationHeatAdvectMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowThermalPropertyMod.o SoilThermalPropertyMod.o +CanopyRadiationTwoStreamMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundAlbedoMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowAgingBatsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowAlbedoBatsMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowAlbedoClassMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceAlbedoMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowAgingBatsMod.o SnowAlbedoBatsMod.o SnowAlbedoClassMod.o \ + GroundAlbedoMod.o CanopyRadiationTwoStreamMod.o +SurfaceRadiationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +EnergyMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + GroundThermalPropertyMod.o SurfaceEnergyFluxVegetatedMod.o \ + SurfaceEnergyFluxBareGroundMod.o SoilSnowTemperatureMainMod.o \ + SoilSnowWaterPhaseChangeMod.o SnowCoverGroundNiu07Mod.o SurfaceEmissivityMod.o \ + GroundRoughnessPropertyMod.o PsychrometricVariableMod.o ResistanceGroundEvaporationMod.o \ + SoilWaterTranspirationMod.o SurfaceAlbedoMod.o SurfaceRadiationMod.o +NoahmpMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + IrrigationPrepareMod.o IrrigationSprinklerMod.o CanopyWaterInterceptMod.o \ + PrecipitationHeatAdvectMod.o EnergyMainMod.o WaterMainMod.o AtmosForcingMod.o \ + BiochemCropMainMod.o BiochemNatureVegMainMod.o PhenologyMainMod.o BalanceErrorCheckMod.o \ + GeneralInitMod.o +HumiditySaturationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceAboveCanopyChen97Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceAboveCanopyMostMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceCanopyStomataBallBerryMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceCanopyStomataJarvisMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + HumiditySaturationMod.o +ResistanceLeafToGroundMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +VaporPressureSaturationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEnergyFluxVegetatedMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + VaporPressureSaturationMod.o ResistanceAboveCanopyMostMod.o \ + ResistanceAboveCanopyChen97Mod.o ResistanceLeafToGroundMod.o \ + ResistanceCanopyStomataBallBerryMod.o ResistanceCanopyStomataJarvisMod.o +ResistanceBareGroundChen97Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceBareGroundMostMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEnergyFluxBareGroundMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + VaporPressureSaturationMod.o ResistanceBareGroundMostMod.o \ + ResistanceBareGroundChen97Mod.o +SoilSnowTemperatureSolverMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + MatrixSolverTriDiagonalMod.o +SoilSnowThermalDiffusionMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilSnowTemperatureMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilSnowTemperatureSolverMod.o SoilSnowThermalDiffusionMod.o +SoilWaterSupercoolKoren99Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilWaterSupercoolNiu06Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilSnowWaterPhaseChangeMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SoilWaterSupercoolKoren99Mod.o SoilWaterSupercoolNiu06Mod.o +GroundRoughnessPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PsychrometricVariableMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceGroundEvaporationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowCoverGroundNiu07Mod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SoilWaterTranspirationMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEmissivityMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +AtmosForcingMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PhenologyMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CropPhotosynthesisMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CropGrowDegreeDayMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CarbonFluxNatureVegMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +CarbonFluxCropMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +BiochemNatureVegMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o CarbonFluxNatureVegMod.o +BiochemCropMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o CarbonFluxCropMod.o \ + CropGrowDegreeDayMod.o CropPhotosynthesisMod.o +IrrigationPrepareMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o IrrigationTriggerMod.o +BalanceErrorCheckMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GeneralInitMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundWaterMmfMod.o: ../utility/Machine.o NoahmpVarType.o ../drivers/hrldas/NoahmpIOVarType.o +BalanceErrorCheckGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +EnergyMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowCoverGlacierMod.o \ + GroundRoughnessPropertyGlacierMod.o GroundThermalPropertyGlacierMod.o \ + SurfaceAlbedoGlacierMod.o SurfaceRadiationGlacierMod.o SurfaceEmissivityGlacierMod.o \ + ResistanceGroundEvaporationGlacierMod.o PsychrometricVariableGlacierMod.o \ + SurfaceEnergyFluxGlacierMod.o GlacierTemperatureMainMod.o GlacierPhaseChangeMod.o +GeneralInitGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GlacierIceThermalPropertyMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GlacierPhaseChangeMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GlacierTemperatureMainMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + GlacierTemperatureSolverMod.o GlacierThermalDiffusionMod.o +GlacierTemperatureSolverMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o MatrixSolverTriDiagonalMod.o +GlacierThermalDiffusionMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundAlbedoGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundRoughnessPropertyGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +GroundThermalPropertyGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + SnowThermalPropertyMod.o GlacierIceThermalPropertyMod.o +NoahmpMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o AtmosForcingMod.o \ + GeneralInitGlacierMod.o PrecipitationHeatAdvectGlacierMod.o EnergyMainGlacierMod.o \ + WaterMainGlacierMod.o BalanceErrorCheckGlacierMod.o +PrecipitationHeatAdvectGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +PsychrometricVariableGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +ResistanceGroundEvaporationGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowCoverGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SnowWaterMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowfallBelowCanopyMod.o \ + SnowpackCompactionMod.o SnowLayerCombineMod.o SnowLayerDivideMod.o \ + SnowpackHydrologyGlacierMod.o +SnowpackHydrologyGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowLayerCombineMod.o +SurfaceAlbedoGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowAgingBatsMod.o \ + SnowAlbedoBatsMod.o SnowAlbedoClassMod.o GroundAlbedoGlacierMod.o +SurfaceEmissivityGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +SurfaceEnergyFluxGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o \ + VaporPressureSaturationMod.o ResistanceBareGroundMostMod.o +SurfaceRadiationGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o +WaterMainGlacierMod.o: ../utility/Machine.o NoahmpVarType.o ConstantDefineMod.o SnowWaterMainGlacierMod.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F90.o: + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS_NONSTD) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I../utility -I../../../../framework + diff --git a/src/core_atmosphere/physics/physics_noahmp/src/MatrixSolverTriDiagonalMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/MatrixSolverTriDiagonalMod.F90 new file mode 100644 index 0000000000..b67a1faf45 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/MatrixSolverTriDiagonalMod.F90 @@ -0,0 +1,73 @@ +module MatrixSolverTriDiagonalMod + +!!! Solve tri-diagonal matrix problem + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine MatrixSolverTriDiagonal(P, A, B, C, D, Delta, IndTopLayer, NumSoilLayer, NumSnowLayerMax) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: ROSR12 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + + implicit none + +! in & out variables + integer , intent(in) :: IndTopLayer ! top layer index: soil layer starts from IndTopLayer = 1 + integer , intent(in) :: NumSoilLayer ! number of soil layers + integer , intent(in) :: NumSnowLayerMax ! maximum number of snow layers + real(kind=kind_noahmp), dimension(-NumSnowLayerMax+1:NumSoilLayer), intent(in) :: A, B, D ! Tri-diagonal matrix elements + real(kind=kind_noahmp), dimension(-NumSnowLayerMax+1:NumSoilLayer), intent(inout) :: C,P,Delta ! Tri-diagonal matrix elements + +! local variables + integer :: K, KK ! loop indices +! ---------------------------------------------------------------------- + + ! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER + C (NumSoilLayer) = 0.0 + P (IndTopLayer) = - C (IndTopLayer) / B (IndTopLayer) + + ! SOLVE THE COEFS FOR THE 1ST SOIL LAYER + Delta (IndTopLayer) = D (IndTopLayer) / B (IndTopLayer) + + ! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NumSoilLayer + do K = IndTopLayer+1, NumSoilLayer + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + Delta (K) = (D (K) - A (K) * Delta (K -1)) * (1.0 / (B (K) + A (K) * P (K -1))) + enddo + + ! SET P TO Delta FOR LOWEST SOIL LAYER + P (NumSoilLayer) = Delta (NumSoilLayer) + + ! ADJUST P FOR SOIL LAYERS 2 THRU NumSoilLayer + do K = IndTopLayer+1, NumSoilLayer + KK = NumSoilLayer - K + (IndTopLayer-1) + 1 + P (KK) = P (KK) * P (KK +1) + Delta (KK) + enddo + + end subroutine MatrixSolverTriDiagonal + +end module MatrixSolverTriDiagonalMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainGlacierMod.F90 new file mode 100644 index 0000000000..4fb104c67b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainGlacierMod.F90 @@ -0,0 +1,77 @@ +module NoahmpMainGlacierMod + +!!! Main NoahMP glacier module including all glacier processes +!!! atmos forcing -> precip heat advect -> main energy -> main water -> balance check + + use Machine + use NoahmpVarType + use ConstantDefineMod + use AtmosForcingMod, only : ProcessAtmosForcing + use GeneralInitGlacierMod, only : GeneralInitGlacier + use PrecipitationHeatAdvectGlacierMod, only : PrecipitationHeatAdvectGlacier + use EnergyMainGlacierMod, only : EnergyMainGlacier + use WaterMainGlacierMod, only : WaterMainGlacier + use BalanceErrorCheckGlacierMod, only : BalanceWaterInitGlacier, & + BalanceWaterCheckGlacier, BalanceEnergyCheckGlacier + + implicit none + +contains + + subroutine NoahmpMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: NOAHMP_SFLX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + !--------------------------------------------------------------------- + ! Atmospheric forcing processing + !--------------------------------------------------------------------- + + call ProcessAtmosForcing(noahmp) + + !--------------------------------------------------------------------- + ! General initialization to prepare key variables + !--------------------------------------------------------------------- + + call GeneralInitGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Prepare for water balance check + !--------------------------------------------------------------------- + + call BalanceWaterInitGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Energy processes + !--------------------------------------------------------------------- + + call PrecipitationHeatAdvectGlacier(noahmp) + call EnergyMainGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Water processes + !--------------------------------------------------------------------- + + call WaterMainGlacier(noahmp) + + !--------------------------------------------------------------------- + ! Error check for energy and water balance + !--------------------------------------------------------------------- + + call BalanceWaterCheckGlacier(noahmp) + call BalanceEnergyCheckGlacier(noahmp) + + !--------------------------------------------------------------------- + ! End of all NoahMP glacier processes + !--------------------------------------------------------------------- + + end subroutine NoahmpMainGlacier + +end module NoahmpMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainMod.F90 new file mode 100644 index 0000000000..c18beb2b71 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpMainMod.F90 @@ -0,0 +1,131 @@ +module NoahmpMainMod + +!!! Main NoahMP module including all column model processes +!!! atmos forcing -> canopy intercept -> precip heat advect -> main energy -> main water -> main biogeochemistry -> balance check + + use Machine + use NoahmpVarType + use ConstantDefineMod + use AtmosForcingMod, only : ProcessAtmosForcing + use GeneralInitMod, only : GeneralInit + use PhenologyMainMod, only : PhenologyMain + use IrrigationPrepareMod, only : IrrigationPrepare + use IrrigationSprinklerMod, only : IrrigationSprinkler + use CanopyWaterInterceptMod, only : CanopyWaterIntercept + use PrecipitationHeatAdvectMod, only : PrecipitationHeatAdvect + use EnergyMainMod, only : EnergyMain + use WaterMainMod, only : WaterMain + use BiochemNatureVegMainMod, only : BiochemNatureVegMain + use BiochemCropMainMod, only : BiochemCropMain + use BalanceErrorCheckMod, only : BalanceWaterInit, BalanceWaterCheck, BalanceEnergyCheck + + implicit none + +contains + + subroutine NoahmpMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: NOAHMP_SFLX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + FlagDynamicVeg => noahmp%config%domain%FlagDynamicVeg ,& ! in, flag to activate dynamic vegetation model + FlagDynamicCrop => noahmp%config%domain%FlagDynamicCrop ,& ! in, flag to activate dynamic crop model + OptCropModel => noahmp%config%nmlist%OptCropModel ,& ! in, option for crop model + IrrigationAmtSprinkler => noahmp%water%state%IrrigationAmtSprinkler ,& ! inout, irrigation water amount [m] for sprinkler + FlagCropland => noahmp%config%domain%FlagCropland & ! out, flag to identify croplands + ) +! ---------------------------------------------------------------------- + + !--------------------------------------------------------------------- + ! Atmospheric forcing processing + !--------------------------------------------------------------------- + + call ProcessAtmosForcing(noahmp) + + !--------------------------------------------------------------------- + ! General initialization to prepare key variables + !--------------------------------------------------------------------- + + call GeneralInit(noahmp) + + !--------------------------------------------------------------------- + ! Prepare for water balance check + !--------------------------------------------------------------------- + + call BalanceWaterInit(noahmp) + + !--------------------------------------------------------------------- + ! Phenology + !--------------------------------------------------------------------- + + call PhenologyMain(noahmp) + + !--------------------------------------------------------------------- + ! Irrigation prepare including trigger + !--------------------------------------------------------------------- + + call IrrigationPrepare(noahmp) + + !--------------------------------------------------------------------- + ! Sprinkler irrigation + !--------------------------------------------------------------------- + + ! call sprinkler irrigation before canopy process to have canopy interception + if ( (FlagCropland .eqv. .true.) .and. (IrrigationAmtSprinkler > 0.0) ) & + call IrrigationSprinkler(noahmp) + + !--------------------------------------------------------------------- + ! Canopy water interception and precip heat advection + !--------------------------------------------------------------------- + + call CanopyWaterIntercept(noahmp) + call PrecipitationHeatAdvect(noahmp) + + !--------------------------------------------------------------------- + ! Energy processes + !--------------------------------------------------------------------- + + call EnergyMain(noahmp) + + !--------------------------------------------------------------------- + ! Water processes + !--------------------------------------------------------------------- + + call WaterMain(noahmp) + + !--------------------------------------------------------------------- + ! Biochem processes (crop and carbon) + !--------------------------------------------------------------------- + + ! for generic vegetation + if ( FlagDynamicVeg .eqv. .true. ) call BiochemNatureVegMain(noahmp) + + ! for explicit crop treatment + if ( (OptCropModel == 1) .and. (FlagDynamicCrop .eqv. .true.) ) & + call BiochemCropMain(noahmp) + + !--------------------------------------------------------------------- + ! Error check for energy and water balance + !--------------------------------------------------------------------- + + call BalanceWaterCheck(noahmp) + call BalanceEnergyCheck(noahmp) + + !--------------------------------------------------------------------- + ! End of all NoahMP column processes + !--------------------------------------------------------------------- + + end associate + + end subroutine NoahmpMain + +end module NoahmpMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/NoahmpVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpVarType.F90 new file mode 100644 index 0000000000..e53501117a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/NoahmpVarType.F90 @@ -0,0 +1,31 @@ +module NoahmpVarType + +!!! Define column (1-D) Noah-MP model variable data types + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use ForcingVarType + use ConfigVarType + use EnergyVarType + use WaterVarType + use BiochemVarType + + implicit none + save + private + + type, public :: noahmp_type + + ! define specific variable types for Noah-MP + type(forcing_type) :: forcing + type(config_type) :: config + type(energy_type) :: energy + type(water_type) :: water + type(biochem_type) :: biochem + + end type noahmp_type + +end module NoahmpVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PhenologyMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PhenologyMainMod.F90 new file mode 100644 index 0000000000..e23193500f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PhenologyMainMod.F90 @@ -0,0 +1,169 @@ +module PhenologyMainMod + +!!! Main Phenology module to estimate vegetation phenology +!!! considering vegeation canopy being buries by snow and evolution in time + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PhenologyMain (noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PHENOLOGY +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: IntpMonth1,IntpMonth2 ! interpolation months + real(kind=kind_noahmp) :: ThicknessCanBury ! thickness of canopy buried by snow [m] + real(kind=kind_noahmp) :: SnowDepthVegBury ! critical snow depth at which short vege is fully covered by snow + real(kind=kind_noahmp) :: DayCurrent ! current day of year (0<=DayCurrent noahmp%config%nmlist%OptDynamicVeg ,& ! in, dynamic vegetation option + OptCropModel => noahmp%config%nmlist%OptCropModel ,& ! in, crop model option + VegType => noahmp%config%domain%VegType ,& ! in, vegetation type + CropType => noahmp%config%domain%CropType ,& ! in, crop type + IndexIcePoint => noahmp%config%domain%IndexIcePoint ,& ! in, land ice flag + IndexBarrenPoint => noahmp%config%domain%IndexBarrenPoint ,& ! in, bare soil flag + IndexWaterPoint => noahmp%config%domain%IndexWaterPoint ,& ! in, water point flag + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + FlagDynamicVeg => noahmp%config%domain%FlagDynamicVeg ,& ! in, flag to activate dynamic vegetation model + FlagDynamicCrop => noahmp%config%domain%FlagDynamicCrop ,& ! in, flag to activate dynamic crop model + Latitude => noahmp%config%domain%Latitude ,& ! in, latitude [deg] + NumDayInYear => noahmp%config%domain%NumDayInYear ,& ! in, Number of days in the particular year + DayJulianInYear => noahmp%config%domain%DayJulianInYear ,& ! in, Julian day of year + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + HeightCanopyBot => noahmp%energy%param%HeightCanopyBot ,& ! in, bottom of canopy [m] + LeafAreaIndexMon => noahmp%energy%param%LeafAreaIndexMon ,& ! in, monthly leaf area index, one-sided + StemAreaIndexMon => noahmp%energy%param%StemAreaIndexMon ,& ! in, monthly stem area index, one-sided + VegFracAnnMax => noahmp%energy%param%VegFracAnnMax ,& ! in, annual maximum vegetation fraction + VegFracGreen => noahmp%energy%param%VegFracGreen ,& ! in, green vegetation fraction + TemperatureMinPhotosyn => noahmp%biochem%param%TemperatureMinPhotosyn ,& ! in, minimum temperature for photosynthesis [K] + PlantGrowStage => noahmp%biochem%state%PlantGrowStage ,& ! in, plant growing stage + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + LeafAreaIndex => noahmp%energy%state%LeafAreaIndex ,& ! inout, LeafAreaIndex, unadjusted for burying by snow + StemAreaIndex => noahmp%energy%state%StemAreaIndex ,& ! inout, StemAreaIndex, unadjusted for burying by snow + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! out, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! out, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! out, green vegetation fraction + CanopyFracSnowBury => noahmp%energy%state%CanopyFracSnowBury ,& ! out, fraction of canopy buried by snow + IndexGrowSeason => noahmp%biochem%state%IndexGrowSeason & ! out, growing season index (0=off, 1=on) + ) +!---------------------------------------------------------------------- + + ! compute LeafAreaIndex based on dynamic vegetation option + if ( CropType == 0 ) then + + ! no dynamic vegetation, use table LeafAreaIndex + if ( (OptDynamicVeg == 1) .or. (OptDynamicVeg == 3) .or. (OptDynamicVeg == 4) ) then + if ( Latitude >= 0.0 ) then + ! Northern Hemisphere + DayCurrent = DayJulianInYear + else + ! Southern Hemisphere. DayCurrent is shifted by 1/2 year. + DayCurrent = mod(DayJulianInYear+(0.5*NumDayInYear), real(NumDayInYear)) + endif + ! interpolate from monthly data to target time point + MonthCurrent = 12.0 * DayCurrent / real(NumDayInYear) + IntpMonth1 = MonthCurrent + 0.5 + IntpMonth2 = IntpMonth1 + 1 + IntpWgt1 = (IntpMonth1 + 0.5) - MonthCurrent + IntpWgt2 = 1.0 - IntpWgt1 + if ( IntpMonth1 < 1 ) IntpMonth1 = 12 + if ( IntpMonth2 > 12 ) IntpMonth2 = 1 + LeafAreaIndex = IntpWgt1 * LeafAreaIndexMon(IntpMonth1) + IntpWgt2 * LeafAreaIndexMon(IntpMonth2) + StemAreaIndex = IntpWgt1 * StemAreaIndexMon(IntpMonth1) + IntpWgt2 * StemAreaIndexMon(IntpMonth2) + endif + + ! no dynamic vegetation, use input LeafAreaIndex time series + if ( (OptDynamicVeg == 7) .or. (OptDynamicVeg == 8) .or. (OptDynamicVeg == 9) ) then + StemAreaIndex = max(0.05, 0.1*LeafAreaIndex) ! set StemAreaIndex to 10% LeafAreaIndex, but not below 0.05 MB: v3.8 + if ( LeafAreaIndex < 0.05 ) StemAreaIndex = 0.0 ! if LeafAreaIndex below minimum, make sure StemAreaIndex = 0 + endif + if ( StemAreaIndex < 0.05 ) StemAreaIndex = 0.0 ! MB: StemAreaIndex CHECK, change to 0.05 v3.6 + if ( (LeafAreaIndex < 0.05) .or. (StemAreaIndex == 0.0) ) LeafAreaIndex = 0.0 ! MB: LeafAreaIndex CHECK + + ! for non-vegetation point + if ( (VegType == IndexWaterPoint) .or. (VegType == IndexBarrenPoint) .or. & + (VegType == IndexIcePoint ) .or. (FlagUrban .eqv. .true.) ) then + LeafAreaIndex = 0.0 + StemAreaIndex = 0.0 + endif + + endif ! CropType == 0 + + ! vegetation fraction buried by snow + ThicknessCanBury = min(max(SnowDepth-HeightCanopyBot,0.0), (HeightCanopyTop-HeightCanopyBot)) + CanopyFracSnowBury = ThicknessCanBury / max(1.0e-06, (HeightCanopyTop-HeightCanopyBot)) ! snow buried fraction + if ( (HeightCanopyTop > 0.0) .and. (HeightCanopyTop <= 1.0) ) then ! MB: change to 1.0 & 0.2 to reflect changes to HeightCanopyTop in MPTABLE + SnowDepthVegBury = HeightCanopyTop * exp(-SnowDepth / 0.2) + CanopyFracSnowBury = min(SnowDepth, SnowDepthVegBury) / SnowDepthVegBury + endif + + ! adjust LeafAreaIndex and StemAreaIndex bused on snow bury + LeafAreaIndEff = LeafAreaIndex * (1.0 - CanopyFracSnowBury) + StemAreaIndEff = StemAreaIndex * (1.0 - CanopyFracSnowBury) + if ( (StemAreaIndEff < 0.05) .and. (CropType == 0) ) StemAreaIndEff = 0.0 ! MB: StemAreaIndEff CHECK, change to 0.05 v3.6 + if ( ((LeafAreaIndEff < 0.05) .or. (StemAreaIndEff == 0.0)) .and. (CropType == 0) ) & + LeafAreaIndEff = 0.0 ! MB: LeafAreaIndex CHECK + + ! set growing season flag + if ( ((TemperatureCanopy > TemperatureMinPhotosyn) .and. (CropType == 0)) .or. & + ((PlantGrowStage > 2) .and. (PlantGrowStage < 7) .and. (CropType > 0))) then + IndexGrowSeason = 1.0 + else + IndexGrowSeason = 0.0 + endif + + ! compute vegetation fraction + ! input green vegetation fraction should be consistent with LeafAreaIndex + if ( (OptDynamicVeg == 1) .or. (OptDynamicVeg == 6) .or. (OptDynamicVeg == 7) ) then ! use VegFrac = VegFracGreen from input + VegFrac = VegFracGreen + elseif ( (OptDynamicVeg == 2) .or. (OptDynamicVeg == 3) .or. (OptDynamicVeg == 8) ) then ! computed VegFrac from LeafAreaIndex & StemAreaIndex + VegFrac = 1.0 - exp(-0.52 * (LeafAreaIndex + StemAreaIndex)) + elseif ( (OptDynamicVeg == 4) .or. (OptDynamicVeg == 5) .or. (OptDynamicVeg == 9) ) then ! use yearly maximum vegetation fraction + VegFrac = VegFracAnnMax + else ! outside existing vegetation options + write(*,*) "Un-recognized dynamic vegetation option (OptDynamicVeg)... " + stop "Error: Namelist parameter OptDynamicVeg unknown" + endif + ! use maximum vegetation fraction for crop run + if ( (OptCropModel > 0) .and. (CropType > 0) ) then + VegFrac = VegFracAnnMax + endif + + ! adjust unreasonable vegetation fraction + if ( VegFrac <= 0.05 ) VegFrac = 0.05 + if ( (FlagUrban .eqv. .true.) .or. (VegType == IndexBarrenPoint) ) VegFrac = 0.0 + if ( (LeafAreaIndEff+StemAreaIndEff) == 0.0 ) VegFrac = 0.0 + + ! determine if activate dynamic vegetation or crop run + FlagDynamicCrop = .false. + FlagDynamicVeg = .false. + if ( (OptDynamicVeg == 2) .or. (OptDynamicVeg == 5) .or. (OptDynamicVeg == 6) ) & + FlagDynamicVeg = .true. + if ( (OptCropModel > 0) .and. (CropType > 0) ) then + FlagDynamicCrop = .true. + FlagDynamicVeg = .false. + endif + + end associate + + end subroutine PhenologyMain + +end module PhenologyMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectGlacierMod.F90 new file mode 100644 index 0000000000..cf0611e742 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectGlacierMod.F90 @@ -0,0 +1,64 @@ +module PrecipitationHeatAdvectGlacierMod + +!!! Estimate heat flux advected from precipitation to glacier ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PrecipitationHeatAdvectGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: none (adapted from PRECIP_HEAT) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: HeatPrcpAirToGrd ! precipitation advected heat - air to ground [W/m2] + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! in, total liquid rainfall [mm/s] before interception + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! in, total snowfall [mm/s] before interception + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! out, snowfall at ground surface [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! out, rainfall at ground surface [mm/s] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd & ! out, precipitation advected heat - bare ground net [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + HeatPrcpAirToGrd = 0.0 + HeatPrecipAdvBareGrd = 0.0 + RainfallGround = RainfallRefHeight + SnowfallGround = SnowfallRefHeight + + ! Heat advection for liquid rainfall + HeatPrcpAirToGrd = RainfallGround * (ConstHeatCapacWater/1000.0) * (TemperatureAirRefHeight - TemperatureGrd) + + ! Heat advection for snowfall + HeatPrcpAirToGrd = HeatPrcpAirToGrd + & + SnowfallGround * (ConstHeatCapacIce/1000.0) * (TemperatureAirRefHeight - TemperatureGrd) + + ! net heat advection + HeatPrecipAdvBareGrd = HeatPrcpAirToGrd + + ! Put some artificial limits here for stability + HeatPrecipAdvBareGrd = max(HeatPrecipAdvBareGrd, -20.0) + HeatPrecipAdvBareGrd = min(HeatPrecipAdvBareGrd, 20.0) + + end associate + + end subroutine PrecipitationHeatAdvectGlacier + +end module PrecipitationHeatAdvectGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectMod.F90 new file mode 100644 index 0000000000..e10f9cac19 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PrecipitationHeatAdvectMod.F90 @@ -0,0 +1,99 @@ +module PrecipitationHeatAdvectMod + +!!! Estimate heat flux advected from precipitation to vegetation and ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PrecipitationHeatAdvect(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: PRECIP_HEAT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! The water and heat portions of PRECIP_HEAT are separated in refactored code +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: HeatPrcpAirToCan ! precipitation advected heat - air to canopy [W/m2] + real(kind=kind_noahmp) :: HeatPrcpCanToGrd ! precipitation advected heat - canopy to ground [W/m2] + real(kind=kind_noahmp) :: HeatPrcpAirToGrd ! precipitation advected heat - air to ground [W/m2] + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RainfallRefHeight => noahmp%water%flux%RainfallRefHeight ,& ! in, total liquid rainfall [mm/s] before interception + SnowfallRefHeight => noahmp%water%flux%SnowfallRefHeight ,& ! in, total snowfall [mm/s] before interception + DripCanopyRain => noahmp%water%flux%DripCanopyRain ,& ! in, drip rate for intercepted rain [mm/s] + ThroughfallRain => noahmp%water%flux%ThroughfallRain ,& ! in, throughfall for rain [mm/s] + DripCanopySnow => noahmp%water%flux%DripCanopySnow ,& ! in, drip (unloading) rate for intercepted snow [mm/s] + ThroughfallSnow => noahmp%water%flux%ThroughfallSnow ,& ! in, throughfall of snowfall [mm/s] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! out, precipitation advected heat - vegetation net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! out, precipitation advected heat - under canopy net [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd & ! out, precipitation advected heat - bare ground net [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + HeatPrcpAirToCan = 0.0 + HeatPrcpCanToGrd = 0.0 + HeatPrcpAirToGrd = 0.0 + HeatPrecipAdvCanopy = 0.0 + HeatPrecipAdvVegGrd = 0.0 + HeatPrecipAdvBareGrd = 0.0 + + ! Heat advection for liquid rainfall + HeatPrcpAirToCan = VegFrac * RainfallRefHeight * (ConstHeatCapacWater/1000.0) * (TemperatureAirRefHeight-TemperatureCanopy) + HeatPrcpCanToGrd = DripCanopyRain * (ConstHeatCapacWater/1000.0) * (TemperatureCanopy-TemperatureGrd) + HeatPrcpAirToGrd = ThroughfallRain * (ConstHeatCapacWater/1000.0) * (TemperatureAirRefHeight-TemperatureGrd) + + ! Heat advection for snowfall + HeatPrcpAirToCan = HeatPrcpAirToCan + & + VegFrac * SnowfallRefHeight * (ConstHeatCapacIce/1000.0) * (TemperatureAirRefHeight-TemperatureCanopy) + HeatPrcpCanToGrd = HeatPrcpCanToGrd + & + DripCanopySnow * (ConstHeatCapacIce/1000.0) * (TemperatureCanopy-TemperatureGrd) + HeatPrcpAirToGrd = HeatPrcpAirToGrd + & + ThroughfallSnow * (ConstHeatCapacIce/1000.0) * (TemperatureAirRefHeight-TemperatureGrd) + + ! net heat advection + HeatPrecipAdvCanopy = HeatPrcpAirToCan - HeatPrcpCanToGrd + HeatPrecipAdvVegGrd = HeatPrcpCanToGrd + HeatPrecipAdvBareGrd = HeatPrcpAirToGrd + + ! adjust for VegFrac + if ( (VegFrac > 0.0) .and. (VegFrac < 1.0) ) then + HeatPrecipAdvVegGrd = HeatPrecipAdvVegGrd / VegFrac ! these will be multiplied by fraction later + HeatPrecipAdvBareGrd = HeatPrecipAdvBareGrd / (1.0-VegFrac) + elseif ( VegFrac <= 0.0 ) then + HeatPrecipAdvBareGrd = HeatPrecipAdvVegGrd + HeatPrecipAdvBareGrd ! for case of canopy getting buried + HeatPrecipAdvVegGrd = 0.0 + HeatPrecipAdvCanopy = 0.0 + elseif ( VegFrac >= 1.0 ) then + HeatPrecipAdvBareGrd = 0.0 + endif + + ! Put some artificial limits here for stability + HeatPrecipAdvCanopy = max(HeatPrecipAdvCanopy , -20.0) + HeatPrecipAdvCanopy = min(HeatPrecipAdvCanopy , 20.0) + HeatPrecipAdvVegGrd = max(HeatPrecipAdvVegGrd , -20.0) + HeatPrecipAdvVegGrd = min(HeatPrecipAdvVegGrd , 20.0) + HeatPrecipAdvBareGrd = max(HeatPrecipAdvBareGrd, -20.0) + HeatPrecipAdvBareGrd = min(HeatPrecipAdvBareGrd, 20.0) + + end associate + + end subroutine PrecipitationHeatAdvect + +end module PrecipitationHeatAdvectMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableGlacierMod.F90 new file mode 100644 index 0000000000..9d645bab4f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableGlacierMod.F90 @@ -0,0 +1,40 @@ +module PsychrometricVariableGlacierMod + +!!! Compute psychrometric variables for glacier ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PsychrometricVariableGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! out, latent heat of vaporization/subli [J/kg], ground + PsychConstGrd => noahmp%energy%state%PsychConstGrd & ! out, psychrometric constant [Pa/K], ground + ) +! ---------------------------------------------------------------------- + + LatHeatVapGrd = ConstLatHeatSublim + PsychConstGrd = ConstHeatCapacAir * PressureAirRefHeight / (0.622 * LatHeatVapGrd) + + end associate + + end subroutine PsychrometricVariableGlacier + +end module PsychrometricVariableGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableMod.F90 new file mode 100644 index 0000000000..66ac20ae98 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/PsychrometricVariableMod.F90 @@ -0,0 +1,63 @@ +module PsychrometricVariableMod + +!!! Compute psychrometric variables for canopy and ground + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine PsychrometricVariable(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + LatHeatVapCanopy => noahmp%energy%state%LatHeatVapCanopy ,& ! out, latent heat of vaporization/subli [J/kg], canopy + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! out, latent heat of vaporization/subli [J/kg], ground + FlagFrozenCanopy => noahmp%energy%state%FlagFrozenCanopy ,& ! out, used to define latent heat pathway + FlagFrozenGround => noahmp%energy%state%FlagFrozenGround ,& ! out, frozen ground (logical) to define latent heat pathway + PsychConstCanopy => noahmp%energy%state%PsychConstCanopy ,& ! out, psychrometric constant [Pa/K], canopy + PsychConstGrd => noahmp%energy%state%PsychConstGrd & ! out, psychrometric constant [Pa/K], ground + ) +! ---------------------------------------------------------------------- + + ! for canopy ! Barlage: add distinction between ground and vegetation in v3.6 + if ( TemperatureCanopy > ConstFreezePoint ) then + LatHeatVapCanopy = ConstLatHeatEvap + FlagFrozenCanopy = .false. + else + LatHeatVapCanopy = ConstLatHeatSublim + FlagFrozenCanopy = .true. + endif + PsychConstCanopy = ConstHeatCapacAir * PressureAirRefHeight / (0.622*LatHeatVapCanopy) + + ! for ground + if ( TemperatureGrd > ConstFreezePoint ) then + LatHeatVapGrd = ConstLatHeatEvap + FlagFrozenGround = .false. + else + LatHeatVapGrd = ConstLatHeatSublim + FlagFrozenGround = .true. + endif + PsychConstGrd = ConstHeatCapacAir * PressureAirRefHeight / (0.622*LatHeatVapGrd) + + end associate + + end subroutine PsychrometricVariable + +end module PsychrometricVariableMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyChen97Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyChen97Mod.F90 new file mode 100644 index 0000000000..1020acb2ac --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyChen97Mod.F90 @@ -0,0 +1,209 @@ +module ResistanceAboveCanopyChen97Mod + +!!! Compute surface resistance and exchange coefficient for momentum and heat +!!! based on Chen et al. (1997, BLM) +!!! This scheme can handle both over open water and over solid surface + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceAboveCanopyChen97(noahmp, IterationInd) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF2 for vegetated portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IterationInd ! iteration index + type(noahmp_type) , intent(inout) :: noahmp + +! local variables + integer :: ILECH, ITR + real(kind=kind_noahmp) :: ZZ, PSLMU, PSLMS, PSLHU, PSLHS + real(kind=kind_noahmp) :: XX, PSPMU, YY, PSPMS, PSPHU, PSPHS + real(kind=kind_noahmp) :: ZILFC, ZU, ZT, RDZ, CXCH, DTHV, DU2 + real(kind=kind_noahmp) :: BTGH, ZSLU, ZSLT, RLOGU, RLOGT, RLMA + real(kind=kind_noahmp) :: ZETALT, ZETALU, ZETAU, ZETAT, XLU4 + real(kind=kind_noahmp) :: XLT4, XU4, XT4, XLU, XLT, XU, XT + real(kind=kind_noahmp) :: PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN +! local parameters + integer , parameter :: ITRMX = 5 + real(kind=kind_noahmp), parameter :: WWST = 1.2 + real(kind=kind_noahmp), parameter :: WWST2 = WWST * WWST + real(kind=kind_noahmp), parameter :: VKRM = 0.40 + real(kind=kind_noahmp), parameter :: EXCM = 0.001 + real(kind=kind_noahmp), parameter :: BETA = 1.0 / 270.0 + real(kind=kind_noahmp), parameter :: BTG = BETA * ConstGravityAcc + real(kind=kind_noahmp), parameter :: ELFC = VKRM * BTG + real(kind=kind_noahmp), parameter :: WOLD = 0.15 + real(kind=kind_noahmp), parameter :: WNEW = 1.0 - WOLD + real(kind=kind_noahmp), parameter :: PIHF = 3.14159265 / 2.0 + real(kind=kind_noahmp), parameter :: EPSU2 = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSUST = 0.07 + real(kind=kind_noahmp), parameter :: EPSIT = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSA = 1.0e-8 + real(kind=kind_noahmp), parameter :: ZTMIN = -5.0 + real(kind=kind_noahmp), parameter :: ZTMAX = 1.0 + real(kind=kind_noahmp), parameter :: HPBL = 1000.0 + real(kind=kind_noahmp), parameter :: SQVISC = 258.2 + real(kind=kind_noahmp), parameter :: RIC = 0.183 + real(kind=kind_noahmp), parameter :: RRIC = 1.0 / RIC + real(kind=kind_noahmp), parameter :: FHNEU = 0.8 + real(kind=kind_noahmp), parameter :: RFC = 0.191 + real(kind=kind_noahmp), parameter :: RFAC = RIC / ( FHNEU * RFC * RFC ) +! local statement functions + ! LECH'S surface functions + PSLMU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLMS(ZZ) = ZZ * RRIC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + PSLHU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLHS(ZZ) = ZZ * RFAC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + ! PAULSON'S surface functions + PSPMU(XX) = -2.0*log( (XX+1.0)*0.5 ) - log( (XX*XX+1.0)*0.5 ) + 2.0*atan(XX) - PIHF + PSPMS(YY) = 5.0 * YY + PSPHU(XX) = -2.0 * log( (XX*XX + 1.0)*0.5 ) + PSPHS(YY) = 5.0 * YY + +! -------------------------------------------------------------------- + associate( & + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Calculate roughness length of heat + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + TemperaturePotRefHeight => noahmp%energy%state%TemperaturePotRefHeight ,& ! in, potential temp at reference height [K] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! in, roughness length [m], momentum, surface + TemperatureCanopyAir => noahmp%energy%state%TemperatureCanopyAir ,& ! in, canopy air temperature [K] + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! inout, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, vegetated + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! inout, exchange coeff [m/s] for heat, above ZeroPlaneDisp, vegetated + MoStabParaAbvCan => noahmp%energy%state%MoStabParaAbvCan ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, vegetated + FrictionVelVertVeg => noahmp%energy%state%FrictionVelVertVeg ,& ! inout, friction velocity [m/s] in vertical direction, vegetated + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! inout, friction velocity [m/s], vegetated + ResistanceMomAbvCan => noahmp%energy%state%ResistanceMomAbvCan ,& ! out, aerodynamic resistance for momentum [s/m], above canopy + ResistanceShAbvCan => noahmp%energy%state%ResistanceShAbvCan ,& ! out, aerodynamic resistance for sensible heat [s/m], above canopy + ResistanceLhAbvCan => noahmp%energy%state%ResistanceLhAbvCan & ! out, aerodynamic resistance for water vapor [s/m], above canopy + ) +! ---------------------------------------------------------------------- + + ! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 + ! C......ZTFC=0.1 + ! ZilitinkevichCoeff: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT + ILECH = 0 + ZILFC = -ZilitinkevichCoeff * VKRM * SQVISC + ZU = RoughLenMomSfc + RDZ = 1.0 / RefHeightAboveGrd + CXCH = EXCM * RDZ + DTHV = TemperaturePotRefHeight - TemperatureCanopyAir + + ! BELJARS correction of friction velocity u* + DU2 = max(WindSpdRefHeight*WindSpdRefHeight, EPSU2) + BTGH = BTG * HPBL + if ( IterationInd == 1 ) then + if ( (BTGH*ExchCoeffShAbvCan*DTHV) /= 0.0 ) then + FrictionVelVertVeg = WWST2 * abs(BTGH*ExchCoeffShAbvCan*DTHV)**(2.0/3.0) + else + FrictionVelVertVeg = 0.0 + endif + FrictionVelVeg = max(sqrt(ExchCoeffMomAbvCan*sqrt(DU2+FrictionVelVertVeg)), EPSUST) + MoStabParaAbvCan = ELFC * ExchCoeffShAbvCan * DTHV / FrictionVelVeg**3 + endif + + ! ZILITINKEVITCH approach for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelVeg*RoughLenMomSfc))*RoughLenMomSfc) + ZSLU = RefHeightAboveGrd + ZU + ZSLT = RefHeightAboveGrd + ZT + RLOGU = log(ZSLU/ZU) + RLOGT = log(ZSLT/ZT) + + ! Monin-Obukhov length scale + ZETALT = max(ZSLT*MoStabParaAbvCan, ZTMIN) + MoStabParaAbvCan = ZETALT / ZSLT + ZETALU = ZSLU * MoStabParaAbvCan + ZETAU = ZU * MoStabParaAbvCan + ZETAT = ZT * MoStabParaAbvCan + if ( ILECH == 0 ) then + if ( MoStabParaAbvCan < 0.0 ) then + XLU4 = 1.0 - 16.0 * ZETALU + XLT4 = 1.0 - 16.0 * ZETALT + XU4 = 1.0 - 16.0 * ZETAU + XT4 = 1.0 - 16.0 * ZETAT + XLU = sqrt(sqrt(XLU4)) + XLT = sqrt(sqrt(XLT4)) + XU = sqrt(sqrt(XU4)) + XT = sqrt(sqrt(XT4)) + PSMZ = PSPMU(XU) + SIMM = PSPMU(XLU) - PSMZ + RLOGU + PSHZ = PSPHU(XT) + SIMH = PSPHU(XLT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + ZETAU = min(ZETAU, ZTMAX/(ZSLU/ZU)) ! Barlage: add limit on ZETAU/ZETAT + ZETAT = min(ZETAT, ZTMAX/(ZSLT/ZT)) ! Barlage: prevent SIMM/SIMH < 0 + PSMZ = PSPMS(ZETAU) + SIMM = PSPMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS(ZETAT) + SIMH = PSPHS(ZETALT) - PSHZ + RLOGT + endif + else ! LECH's functions + if ( MoStabParaAbvCan < 0.0 ) then + PSMZ = PSLMU(ZETAU) + SIMM = PSLMU(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU(ZETAT) + SIMH = PSLHU(ZETALT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + PSMZ = PSLMS(ZETAU) + SIMM = PSLMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS(ZETAT) + SIMH = PSLHS(ZETALT) - PSHZ + RLOGT + endif + endif + + ! BELJARS correction of friction velocity u* + FrictionVelVeg = max(sqrt(ExchCoeffMomAbvCan*sqrt(DU2+FrictionVelVertVeg)), EPSUST) + + ! ZILITINKEVITCH fix for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelVeg*RoughLenMomSfc))*RoughLenMomSfc) + ZSLT = RefHeightAboveGrd + ZT + RLOGT = log(ZSLT/ZT) + USTARK = FrictionVelVeg * VKRM + + ! avoid tangent linear problems near zero + if ( SIMM < 1.0e-6 ) SIMM = 1.0e-6 ! Limit stability function + ExchCoeffMomAbvCan = max(USTARK/SIMM, CXCH) + if ( SIMH < 1.0e-6 ) SIMH = 1.0e-6 ! Limit stability function + ExchCoeffShAbvCan = max(USTARK/SIMH, CXCH) + + ! update vertical friction velocity w* + if ( (BTGH*ExchCoeffShAbvCan*DTHV) /= 0.0 ) then + FrictionVelVertVeg = WWST2 * abs(BTGH*ExchCoeffShAbvCan*DTHV)**(2.0/3.0) + else + FrictionVelVertVeg = 0.0 + endif + + ! update M-O stability parameter + RLMN = ELFC * ExchCoeffShAbvCan * DTHV / FrictionVelVeg**3 + RLMA = MoStabParaAbvCan * WOLD + RLMN * WNEW + MoStabParaAbvCan = RLMA + + ! Undo the multiplication by windspeed that applies to exchange coeff + ExchCoeffShAbvCan = ExchCoeffShAbvCan / WindSpdRefHeight + ExchCoeffMomAbvCan = ExchCoeffMomAbvCan / WindSpdRefHeight + + ! compute aerodynamic resistance + ResistanceMomAbvCan = max(1.0, 1.0/(ExchCoeffMomAbvCan*WindSpdRefHeight)) + ResistanceShAbvCan = max(1.0, 1.0/(ExchCoeffShAbvCan*WindSpdRefHeight)) + ResistanceLhAbvCan = ResistanceShAbvCan + + end associate + + end subroutine ResistanceAboveCanopyChen97 + +end module ResistanceAboveCanopyChen97Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyMostMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyMostMod.F90 new file mode 100644 index 0000000000..f257c39745 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceAboveCanopyMostMod.F90 @@ -0,0 +1,176 @@ +module ResistanceAboveCanopyMostMod + +!!! Compute surface resistance and drag coefficient for momentum and heat +!!! based on Monin-Obukhov (M-O) Similarity Theory (MOST) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceAboveCanopyMOST(noahmp, IterationInd, HeatSensibleTmp, MoStabParaSgn) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF1 for vegetated portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IterationInd ! iteration index + integer , intent(inout) :: MoStabParaSgn ! number of times moz changes sign + real(kind=kind_noahmp), intent(in ) :: HeatSensibleTmp ! temporary sensible heat flux (w/m2) in each iteration + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: TMPCM ! temporary calculation for ExchCoeffMomAbvCan + real(kind=kind_noahmp) :: TMPCH ! temporary calculation for CH + real(kind=kind_noahmp) :: FMNEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FHNEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: MOZOLD ! Monin-Obukhov stability parameter from prior iteration + real(kind=kind_noahmp) :: TMP1,TMP2,TMP3,TMP4,TMP5 ! temporary calculation + real(kind=kind_noahmp) :: TVIR ! temporary virtual temperature [K] + real(kind=kind_noahmp) :: TMPCM2 ! temporary calculation for CM2 + real(kind=kind_noahmp) :: TMPCH2 ! temporary calculation for CH2 + real(kind=kind_noahmp) :: FM2NEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FH2NEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: TMP12,TMP22,TMP32 ! temporary calculation + real(kind=kind_noahmp) :: CMFM, CHFH, CM2FM2, CH2FH2 ! temporary calculation + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! in, zero plane displacement [m] + RoughLenShCanopy => noahmp%energy%state%RoughLenShCanopy ,& ! in, roughness length [m], sensible heat, vegetated + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! in, roughness length [m], momentum, surface + MoStabCorrMomAbvCan => noahmp%energy%state%MoStabCorrMomAbvCan ,& ! inout, M-O momentum stability correction, above ZeroPlaneDispSfc, vegetated + MoStabCorrShAbvCan => noahmp%energy%state%MoStabCorrShAbvCan ,& ! inout, M-O sen heat stability correction, above ZeroPlaneDispSfc, vegetated + MoStabCorrMomVeg2m => noahmp%energy%state%MoStabCorrMomVeg2m ,& ! inout, M-O momentum stability correction, 2m, vegetated + MoStabCorrShVeg2m => noahmp%energy%state%MoStabCorrShVeg2m ,& ! inout, M-O sen heat stability correction, 2m, vegetated + MoStabParaAbvCan => noahmp%energy%state%MoStabParaAbvCan ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDispSfc, vegetated + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! inout, friction velocity [m/s], vegetated + MoStabParaVeg2m => noahmp%energy%state%MoStabParaVeg2m ,& ! out, Monin-Obukhov stability (z/L), 2m, vegetated + MoLengthAbvCan => noahmp%energy%state%MoLengthAbvCan ,& ! out, Monin-Obukhov length [m], above ZeroPlaneDispSfc, vegetated + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! out, drag coefficient for momentum, above ZeroPlaneDispSfc, vegetated + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! out, exchange coefficient for heat, above ZeroPlaneDispSfc, vegetated + ExchCoeffSh2mVegMo => noahmp%energy%state%ExchCoeffSh2mVegMo ,& ! out, exchange coefficient for heat, 2m, vegetated + ResistanceMomAbvCan => noahmp%energy%state%ResistanceMomAbvCan ,& ! out, aerodynamic resistance for momentum [s/m], above canopy + ResistanceShAbvCan => noahmp%energy%state%ResistanceShAbvCan ,& ! out, aerodynamic resistance for sensible heat [s/m], above canopy + ResistanceLhAbvCan => noahmp%energy%state%ResistanceLhAbvCan & ! out, aerodynamic resistance for water vapor [s/m], above canopy + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + MOZOLD = MoStabParaAbvCan ! M-O stability parameter for next iteration + if ( RefHeightAboveGrd <= ZeroPlaneDispSfc ) then + write(*,*) "WARNING: critical problem: RefHeightAboveGrd <= ZeroPlaneDispSfc; model stops" + stop "Error in ResistanceAboveCanopyMostMod.F90" + endif + + ! temporary drag coefficients + TMPCM = log((RefHeightAboveGrd - ZeroPlaneDispSfc) / RoughLenMomSfc) + TMPCH = log((RefHeightAboveGrd - ZeroPlaneDispSfc) / RoughLenShCanopy) + TMPCM2 = log((2.0 + RoughLenMomSfc) / RoughLenMomSfc) + TMPCH2 = log((2.0 + RoughLenShCanopy) / RoughLenShCanopy) + + ! compute M-O stability parameter + if ( IterationInd == 1 ) then + FrictionVelVeg = 0.0 + MoStabParaAbvCan = 0.0 + MoLengthAbvCan = 0.0 + MoStabParaVeg2m = 0.0 + else + TVIR = (1.0 + 0.61*SpecHumidityRefHeight) * TemperatureAirRefHeight + TMP1 = ConstVonKarman * (ConstGravityAcc/TVIR) * HeatSensibleTmp / (DensityAirRefHeight*ConstHeatCapacAir) + if ( abs(TMP1) <= MPE ) TMP1 = MPE + MoLengthAbvCan = -1.0 * FrictionVelVeg**3 / TMP1 + MoStabParaAbvCan = min((RefHeightAboveGrd - ZeroPlaneDispSfc) / MoLengthAbvCan, 1.0) + MoStabParaVeg2m = min((2.0 + RoughLenShCanopy) / MoLengthAbvCan, 1.0) + endif + + ! accumulate number of times moz changes sign. + if ( MOZOLD*MoStabParaAbvCan < 0.0 ) MoStabParaSgn = MoStabParaSgn + 1 + if ( MoStabParaSgn >= 2 ) then + MoStabParaAbvCan = 0.0 + MoStabCorrMomAbvCan = 0.0 + MoStabCorrShAbvCan = 0.0 + MoStabParaVeg2m = 0.0 + MoStabCorrMomVeg2m = 0.0 + MoStabCorrShVeg2m = 0.0 + endif + + ! evaluate stability-dependent variables using moz from prior iteration + if ( MoStabParaAbvCan < 0.0 ) then + TMP1 = (1.0 - 16.0 * MoStabParaAbvCan)**0.25 + TMP2 = log((1.0 + TMP1*TMP1) / 2.0) + TMP3 = log((1.0 + TMP1) / 2.0) + FMNEW = 2.0 * TMP3 + TMP2 - 2.0 * atan(TMP1) + 1.5707963 + FHNEW = 2 * TMP2 + ! 2-meter quantities + TMP12 = (1.0 - 16.0 * MoStabParaVeg2m)**0.25 + TMP22 = log((1.0 + TMP12*TMP12) / 2.0) + TMP32 = log((1.0 + TMP12) / 2.0) + FM2NEW = 2.0 * TMP32 + TMP22 - 2.0 * atan(TMP12) + 1.5707963 + FH2NEW = 2 * TMP22 + else + FMNEW = -5.0 * MoStabParaAbvCan + FHNEW = FMNEW + FM2NEW = -5.0 * MoStabParaVeg2m + FH2NEW = FM2NEW + endif + + ! except for first iteration, weight stability factors for previous + ! iteration to help avoid flip-flops from one iteration to the next + if ( IterationInd == 1 ) then + MoStabCorrMomAbvCan = FMNEW + MoStabCorrShAbvCan = FHNEW + MoStabCorrMomVeg2m = FM2NEW + MoStabCorrShVeg2m = FH2NEW + else + MoStabCorrMomAbvCan = 0.5 * (MoStabCorrMomAbvCan + FMNEW) + MoStabCorrShAbvCan = 0.5 * (MoStabCorrShAbvCan + FHNEW) + MoStabCorrMomVeg2m = 0.5 * (MoStabCorrMomVeg2m + FM2NEW) + MoStabCorrShVeg2m = 0.5 * (MoStabCorrShVeg2m + FH2NEW) + endif + + ! exchange coefficients + MoStabCorrShAbvCan = min(MoStabCorrShAbvCan , 0.9*TMPCH) + MoStabCorrMomAbvCan = min(MoStabCorrMomAbvCan, 0.9*TMPCM) + MoStabCorrShVeg2m = min(MoStabCorrShVeg2m , 0.9*TMPCH2) + MoStabCorrMomVeg2m = min(MoStabCorrMomVeg2m , 0.9*TMPCM2) + CMFM = TMPCM - MoStabCorrMomAbvCan + CHFH = TMPCH - MoStabCorrShAbvCan + CM2FM2 = TMPCM2 - MoStabCorrMomVeg2m + CH2FH2 = TMPCH2 - MoStabCorrShVeg2m + if ( abs(CMFM) <= MPE ) CMFM = MPE + if ( abs(CHFH) <= MPE ) CHFH = MPE + if ( abs(CM2FM2) <= MPE ) CM2FM2 = MPE + if ( abs(CH2FH2) <= MPE ) CH2FH2 = MPE + ExchCoeffMomAbvCan = ConstVonKarman * ConstVonKarman / (CMFM * CMFM) + ExchCoeffShAbvCan = ConstVonKarman * ConstVonKarman / (CMFM * CHFH) + !ExchCoeffSh2mVegMo = ConstVonKarman * ConstVonKarman / (CM2FM2 * CH2FH2) + + ! friction velocity + FrictionVelVeg = WindSpdRefHeight * sqrt(ExchCoeffMomAbvCan) + ExchCoeffSh2mVegMo = ConstVonKarman * FrictionVelVeg / CH2FH2 + + ! aerodynamic resistance + ResistanceMomAbvCan = max(1.0, 1.0/(ExchCoeffMomAbvCan*WindSpdRefHeight)) + ResistanceShAbvCan = max(1.0, 1.0/(ExchCoeffShAbvCan*WindSpdRefHeight)) + ResistanceLhAbvCan = ResistanceShAbvCan + + end associate + + end subroutine ResistanceAboveCanopyMOST + +end module ResistanceAboveCanopyMostMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundChen97Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundChen97Mod.F90 new file mode 100644 index 0000000000..f3510ce0ec --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundChen97Mod.F90 @@ -0,0 +1,215 @@ +module ResistanceBareGroundChen97Mod + +!!! Compute bare ground resistance and exchange coefficient for momentum and heat +!!! based on Chen et al. (1997, BLM) +!!! This scheme can handle both over open water and over solid surface + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceBareGroundChen97(noahmp, IndIter) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF2 for bare ground portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + integer , intent(in ) :: IndIter ! iteration index + type(noahmp_type) , intent(inout) :: noahmp + +! local variables + integer :: ILECH, ITR + real(kind=kind_noahmp) :: ZZ, PSLMU, PSLMS, PSLHU, PSLHS + real(kind=kind_noahmp) :: XX, PSPMU, YY, PSPMS, PSPHU, PSPHS + real(kind=kind_noahmp) :: ZILFC, ZU, ZT, RDZ, CXCH, DTHV, DU2 + real(kind=kind_noahmp) :: BTGH, ZSLU, ZSLT, RLOGU, RLOGT, RLMA + real(kind=kind_noahmp) :: ZETALT, ZETALU, ZETAU, ZETAT, XLU4 + real(kind=kind_noahmp) :: XLT4, XU4, XT4, XLU, XLT, XU, XT + real(kind=kind_noahmp) :: PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN +! local parameters + integer , parameter :: ITRMX = 5 + real(kind=kind_noahmp), parameter :: WWST = 1.2 + real(kind=kind_noahmp), parameter :: WWST2 = WWST * WWST + real(kind=kind_noahmp), parameter :: VKRM = 0.40 + real(kind=kind_noahmp), parameter :: EXCM = 0.001 + real(kind=kind_noahmp), parameter :: BETA = 1.0 / 270.0 + real(kind=kind_noahmp), parameter :: BTG = BETA * ConstGravityAcc + real(kind=kind_noahmp), parameter :: ELFC = VKRM * BTG + real(kind=kind_noahmp), parameter :: WOLD = 0.15 + real(kind=kind_noahmp), parameter :: WNEW = 1.0 - WOLD + real(kind=kind_noahmp), parameter :: PIHF = 3.14159265 / 2.0 + real(kind=kind_noahmp), parameter :: EPSU2 = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSUST = 0.07 + real(kind=kind_noahmp), parameter :: EPSIT = 1.0e-4 + real(kind=kind_noahmp), parameter :: EPSA = 1.0e-8 + real(kind=kind_noahmp), parameter :: ZTMIN = -5.0 + real(kind=kind_noahmp), parameter :: ZTMAX = 1.0 + real(kind=kind_noahmp), parameter :: HPBL = 1000.0 + real(kind=kind_noahmp), parameter :: SQVISC = 258.2 + real(kind=kind_noahmp), parameter :: RIC = 0.183 + real(kind=kind_noahmp), parameter :: RRIC = 1.0 / RIC + real(kind=kind_noahmp), parameter :: FHNEU = 0.8 + real(kind=kind_noahmp), parameter :: RFC = 0.191 + real(kind=kind_noahmp), parameter :: RFAC = RIC / ( FHNEU * RFC * RFC ) +! local statement functions + ! LECH'S surface functions + PSLMU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLMS(ZZ) = ZZ * RRIC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + PSLHU(ZZ) = -0.96 * log(1.0 - 4.5 * ZZ) + PSLHS(ZZ) = ZZ * RFAC - 2.076 * (1.0 - 1.0/(ZZ + 1.0)) + ! PAULSON'S surface functions + PSPMU(XX) = -2.0*log( (XX+1.0)*0.5 ) - log( (XX*XX+1.0)*0.5 ) + 2.0*atan(XX) - PIHF + PSPMS(YY) = 5.0 * YY + PSPHU(XX) = -2.0 * log( (XX*XX + 1.0)*0.5 ) + PSPHS(YY) = 5.0 * YY + +! -------------------------------------------------------------------- + associate( & + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Calculate roughness length of heat + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + TemperaturePotRefHeight => noahmp%energy%state%TemperaturePotRefHeight ,& ! in, potential temp at reference height [K] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! in, bare ground temperature [K] + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! inout, exchange coeff [m/s] momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! inout, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + FrictionVelVertBare => noahmp%energy%state%FrictionVelVertBare ,& ! inout, friction velocity [m/s] in vertical direction, bare ground + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! inout, friction velocity [m/s], bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd & ! out, aerodynamic resistance for water vapor [s/m], bare ground + ) +! ---------------------------------------------------------------------- + + ! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 + ! C......ZTFC=0.1 + ! ZilitinkevichCoeff: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT + ILECH = 0 + ZILFC = -ZilitinkevichCoeff * VKRM * SQVISC + ZU = RoughLenMomGrd + RDZ = 1.0 / RefHeightAboveGrd + CXCH = EXCM * RDZ + DTHV = TemperaturePotRefHeight - TemperatureGrdBare + + ! BELJARS correction of friction velocity u* + DU2 = max(WindSpdRefHeight*WindSpdRefHeight, EPSU2) + BTGH = BTG * HPBL + if ( IndIter == 1 ) then + if ( (BTGH*ExchCoeffShBare*DTHV) /= 0.0 ) then + FrictionVelVertBare = WWST2 * abs(BTGH*ExchCoeffShBare*DTHV)**(2.0/3.0) + else + FrictionVelVertBare = 0.0 + endif + FrictionVelBare = max(sqrt(ExchCoeffMomBare*sqrt(DU2+FrictionVelVertBare)), EPSUST) + MoStabParaBare = ELFC * ExchCoeffShBare * DTHV / FrictionVelBare**3 + endif + + ! ZILITINKEVITCH approach for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelBare*RoughLenMomGrd))*RoughLenMomGrd) + ZSLU = RefHeightAboveGrd + ZU + ZSLT = RefHeightAboveGrd + ZT + RLOGU = log(ZSLU / ZU) + RLOGT = log(ZSLT / ZT) + + ! Monin-Obukhov length scale + ZETALT = max(ZSLT*MoStabParaBare, ZTMIN) + MoStabParaBare = ZETALT / ZSLT + ZETALU = ZSLU * MoStabParaBare + ZETAU = ZU * MoStabParaBare + ZETAT = ZT * MoStabParaBare + if ( ILECH == 0 ) then + if ( MoStabParaBare < 0.0 ) then + XLU4 = 1.0 - 16.0 * ZETALU + XLT4 = 1.0 - 16.0 * ZETALT + XU4 = 1.0 - 16.0 * ZETAU + XT4 = 1.0 - 16.0 * ZETAT + XLU = sqrt(sqrt(XLU4)) + XLT = sqrt(sqrt(XLT4)) + XU = sqrt(sqrt(XU4)) + XT = sqrt(sqrt(XT4)) + PSMZ = PSPMU(XU) + SIMM = PSPMU(XLU) - PSMZ + RLOGU + PSHZ = PSPHU(XT) + SIMH = PSPHU(XLT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + ZETAU = min(ZETAU, ZTMAX/(ZSLU/ZU)) ! Barlage: add limit on ZETAU/ZETAT + ZETAT = min(ZETAT, ZTMAX/(ZSLT/ZT)) ! Barlage: prevent SIMM/SIMH < 0 + PSMZ = PSPMS(ZETAU) + SIMM = PSPMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS(ZETAT) + SIMH = PSPHS(ZETALT) - PSHZ + RLOGT + endif + else ! LECH's functions + if ( MoStabParaBare < 0.0 ) then + PSMZ = PSLMU(ZETAU) + SIMM = PSLMU(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU(ZETAT) + SIMH = PSLHU(ZETALT) - PSHZ + RLOGT + else + ZETALU = min(ZETALU, ZTMAX) + ZETALT = min(ZETALT, ZTMAX) + PSMZ = PSLMS(ZETAU) + SIMM = PSLMS(ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS(ZETAT) + SIMH = PSLHS(ZETALT) - PSHZ + RLOGT + endif + endif + + ! BELJARS correction of friction velocity u* + FrictionVelBare = max(sqrt(ExchCoeffMomBare*sqrt(DU2+FrictionVelVertBare)), EPSUST) + + ! ZILITINKEVITCH fix for ZT + ZT = max(1.0e-6, exp(ZILFC*sqrt(FrictionVelBare*RoughLenMomGrd))*RoughLenMomGrd) + ZSLT = RefHeightAboveGrd + ZT + RLOGT = log(ZSLT/ZT) + USTARK = FrictionVelBare * VKRM + + ! avoid tangent linear problems near zero + if ( SIMM < 1.0e-6 ) SIMM = 1.0e-6 ! Limit stability function + ExchCoeffMomBare = max(USTARK/SIMM, CXCH) + if ( SIMH < 1.0e-6 ) SIMH = 1.0e-6 ! Limit stability function + ExchCoeffShBare = max(USTARK/SIMH, CXCH) + + ! update vertical friction velocity w* + if ( BTGH*ExchCoeffShBare*DTHV /= 0.0 ) then + FrictionVelVertBare = WWST2 * abs(BTGH*ExchCoeffShBare*DTHV)**(2.0/3.0) + else + FrictionVelVertBare = 0.0 + endif + + ! update M-O stability parameter + RLMN = ELFC * ExchCoeffShBare * DTHV / FrictionVelBare**3 + RLMA = MoStabParaBare * WOLD + RLMN * WNEW + MoStabParaBare = RLMA + + ! Undo the multiplication by windspeed that applies to exchange coeff + ExchCoeffShBare = ExchCoeffShBare / WindSpdRefHeight + ExchCoeffMomBare = ExchCoeffMomBare / WindSpdRefHeight + if ( SnowDepth > 0.0 ) then + ExchCoeffMomBare = min(0.01, ExchCoeffMomBare) ! exch coeff is too large, causing + ExchCoeffShBare = min(0.01, ExchCoeffShBare) ! computational instability + endif + + ! compute aerodynamic resistance + ResistanceMomBareGrd = max(1.0, 1.0/(ExchCoeffMomBare*WindSpdRefHeight)) + ResistanceShBareGrd = max(1.0, 1.0/(ExchCoeffShBare*WindSpdRefHeight)) + ResistanceLhBareGrd = ResistanceShBareGrd + + end associate + + end subroutine ResistanceBareGroundChen97 + +end module ResistanceBareGroundChen97Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundMostMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundMostMod.F90 new file mode 100644 index 0000000000..5c47e7437f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceBareGroundMostMod.F90 @@ -0,0 +1,177 @@ +module ResistanceBareGroundMostMod + +!!! Compute bare ground resistance and drag coefficient for momentum and heat +!!! based on Monin-Obukhov (M-O) Similarity Theory (MOST) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceBareGroundMOST(noahmp, IndIter, HeatSensibleTmp, MoStabParaSgn) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SFCDIF1 for bare ground portion +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + integer , intent(in ) :: IndIter ! iteration index + integer , intent(inout) :: MoStabParaSgn ! number of times moz changes sign + real(kind=kind_noahmp), intent(in ) :: HeatSensibleTmp ! temporary sensible heat flux (w/m2) in each iteration + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: TMPCM ! temporary calculation for CM + real(kind=kind_noahmp) :: TMPCH ! temporary calculation for CH + real(kind=kind_noahmp) :: FMNEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FHNEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: MOZOLD ! Monin-Obukhov stability parameter from prior iteration + real(kind=kind_noahmp) :: TMP1,TMP2,TMP3,TMP4,TMP5 ! temporary calculation + real(kind=kind_noahmp) :: TVIR ! temporary virtual temperature (k) + real(kind=kind_noahmp) :: TMPCM2 ! temporary calculation for CM2 + real(kind=kind_noahmp) :: TMPCH2 ! temporary calculation for CH2 + real(kind=kind_noahmp) :: FM2NEW ! stability correction factor, momentum, for current moz + real(kind=kind_noahmp) :: FH2NEW ! stability correction factor, sen heat, for current moz + real(kind=kind_noahmp) :: TMP12,TMP22,TMP32 ! temporary calculation + real(kind=kind_noahmp) :: CMFM, CHFH, CM2FM2, CH2FH2 ! temporary calculation + +! -------------------------------------------------------------------- + associate( & + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, reference height [m] above ground + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + ZeroPlaneDispGrd => noahmp%energy%state%ZeroPlaneDispGrd ,& ! in, ground zero plane displacement [m] + RoughLenShBareGrd => noahmp%energy%state%RoughLenShBareGrd ,& ! in, roughness length [m], sensible heat, bare ground + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + MoStabCorrMomBare => noahmp%energy%state%MoStabCorrMomBare ,& ! inout, M-O momentum stability correction, above ZeroPlaneDisp, bare ground + MoStabCorrShBare => noahmp%energy%state%MoStabCorrShBare ,& ! inout, M-O sen heat stability correction, above ZeroPlaneDisp, bare ground + MoStabCorrMomBare2m => noahmp%energy%state%MoStabCorrMomBare2m ,& ! inout, M-O momentum stability correction, 2m, bare ground + MoStabCorrShBare2m => noahmp%energy%state%MoStabCorrShBare2m ,& ! inout, M-O sen heat stability correction, 2m, bare ground + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! inout, friction velocity [m/s], bare ground + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! inout, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + MoStabParaBare2m => noahmp%energy%state%MoStabParaBare2m ,& ! out, Monin-Obukhov stability (z/L), 2m, bare ground + MoLengthBare => noahmp%energy%state%MoLengthBare ,& ! out, Monin-Obukhov length [m], above ZeroPlaneDisp, bare ground + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! out, exchange coeff [m/s] for momentum, above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! out, exchange coeff [m/s] for heat, above ZeroPlaneDisp, bare ground + ExchCoeffSh2mBareMo => noahmp%energy%state%ExchCoeffSh2mBareMo ,& ! out, exchange coeff [m/s] for heat, 2m, bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd & ! out, aerodynamic resistance for water vapor [s/m], bare ground + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + MOZOLD = MoStabParaBare ! M-O stability parameter for next iteration + if ( RefHeightAboveGrd <= ZeroPlaneDispGrd ) then + write(*,*) "WARNING: critical problem: RefHeightAboveGrd <= ZeroPlaneDispGrd; model stops" + stop "Error in ResistanceBareGroundMostMod.F90" + endif + + ! temporary drag coefficients + TMPCM = log((RefHeightAboveGrd - ZeroPlaneDispGrd) / RoughLenMomGrd) + TMPCH = log((RefHeightAboveGrd - ZeroPlaneDispGrd) / RoughLenShBareGrd) + TMPCM2 = log((2.0 + RoughLenMomGrd) / RoughLenMomGrd) + TMPCH2 = log((2.0 + RoughLenShBareGrd) / RoughLenShBareGrd) + + ! compute M-O stability parameter + if ( IndIter == 1 ) then + FrictionVelBare = 0.0 + MoStabParaBare = 0.0 + MoLengthBare = 0.0 + MoStabParaBare2m = 0.0 + else + TVIR = (1.0 + 0.61*SpecHumidityRefHeight) * TemperatureAirRefHeight + TMP1 = ConstVonKarman * (ConstGravityAcc/TVIR) * HeatSensibleTmp / (DensityAirRefHeight*ConstHeatCapacAir) + if ( abs(TMP1) <= MPE ) TMP1 = MPE + MoLengthBare = -1.0 * FrictionVelBare**3 / TMP1 + MoStabParaBare = min((RefHeightAboveGrd - ZeroPlaneDispGrd) / MoLengthBare, 1.0) + MoStabParaBare2m = min((2.0 + RoughLenShBareGrd) / MoLengthBare, 1.0) + endif + + ! accumulate number of times moz changes sign. + if ( MOZOLD*MoStabParaBare < 0.0 ) MoStabParaSgn = MoStabParaSgn + 1 + if ( MoStabParaSgn >= 2 ) then + MoStabParaBare = 0.0 + MoStabCorrMomBare = 0.0 + MoStabCorrShBare = 0.0 + MoStabParaBare2m = 0.0 + MoStabCorrMomBare2m = 0.0 + MoStabCorrShBare2m = 0.0 + endif + + ! evaluate stability-dependent variables using moz from prior iteration + if ( MoStabParaBare < 0.0 ) then + TMP1 = (1.0 - 16.0 * MoStabParaBare)**0.25 + TMP2 = log((1.0 + TMP1*TMP1) / 2.0) + TMP3 = log((1.0 + TMP1) / 2.0) + FMNEW = 2.0 * TMP3 + TMP2 - 2.0 * atan(TMP1) + 1.5707963 + FHNEW = 2 * TMP2 + ! 2-meter quantities + TMP12 = (1.0 - 16.0 * MoStabParaBare2m)**0.25 + TMP22 = log((1.0 + TMP12*TMP12) / 2.0) + TMP32 = log((1.0 + TMP12) / 2.0) + FM2NEW = 2.0 * TMP32 + TMP22 - 2.0 * atan(TMP12) + 1.5707963 + FH2NEW = 2 * TMP22 + else + FMNEW = -5.0 * MoStabParaBare + FHNEW = FMNEW + FM2NEW = -5.0 * MoStabParaBare2m + FH2NEW = FM2NEW + endif + + ! except for first iteration, weight stability factors for previous + ! iteration to help avoid flip-flops from one iteration to the next + if ( IndIter == 1 ) then + MoStabCorrMomBare = FMNEW + MoStabCorrShBare = FHNEW + MoStabCorrMomBare2m = FM2NEW + MoStabCorrShBare2m = FH2NEW + else + MoStabCorrMomBare = 0.5 * (MoStabCorrMomBare + FMNEW) + MoStabCorrShBare = 0.5 * (MoStabCorrShBare + FHNEW) + MoStabCorrMomBare2m = 0.5 * (MoStabCorrMomBare2m + FM2NEW) + MoStabCorrShBare2m = 0.5 * (MoStabCorrShBare2m + FH2NEW) + endif + + ! exchange coefficients + MoStabCorrShBare = min(MoStabCorrShBare , 0.9*TMPCH ) + MoStabCorrMomBare = min(MoStabCorrMomBare , 0.9*TMPCM ) + MoStabCorrShBare2m = min(MoStabCorrShBare2m , 0.9*TMPCH2) + MoStabCorrMomBare2m = min(MoStabCorrMomBare2m, 0.9*TMPCM2) + CMFM = TMPCM - MoStabCorrMomBare + CHFH = TMPCH - MoStabCorrShBare + CM2FM2 = TMPCM2 - MoStabCorrMomBare2m + CH2FH2 = TMPCH2 - MoStabCorrShBare2m + if ( abs(CMFM) <= MPE ) CMFM = MPE + if ( abs(CHFH) <= MPE ) CHFH = MPE + if ( abs(CM2FM2) <= MPE ) CM2FM2 = MPE + if ( abs(CH2FH2) <= MPE ) CH2FH2 = MPE + ExchCoeffMomBare = ConstVonKarman * ConstVonKarman / (CMFM * CMFM) + ExchCoeffShBare = ConstVonKarman * ConstVonKarman / (CMFM * CHFH) + !ExchCoeffSh2mBareMo = ConstVonKarman * ConstVonKarman / (CM2FM2 * CH2FH2) + + ! friction velocity + FrictionVelBare = WindSpdRefHeight * sqrt(ExchCoeffMomBare) + ExchCoeffSh2mBareMo = ConstVonKarman * FrictionVelBare / CH2FH2 + + ! aerodynamic resistance + ResistanceMomBareGrd = max(1.0, 1.0/(ExchCoeffMomBare*WindSpdRefHeight)) + ResistanceShBareGrd = max(1.0, 1.0/(ExchCoeffShBare*WindSpdRefHeight)) + ResistanceLhBareGrd = ResistanceShBareGrd + + end associate + + end subroutine ResistanceBareGroundMOST + +end module ResistanceBareGroundMostMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataBallBerryMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataBallBerryMod.F90 new file mode 100644 index 0000000000..d479bec047 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataBallBerryMod.F90 @@ -0,0 +1,173 @@ +module ResistanceCanopyStomataBallBerryMod + +!!! Compute canopy stomatal resistance and foliage photosynthesis based on Ball-Berry scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceCanopyStomataBallBerry(noahmp, IndexShade) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: STOMATA +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IndexShade ! index for sunlit/shaded (0=sunlit;1=shaded) + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndIter ! iteration index + integer, parameter :: NumIter = 3 ! number of iterations + real(kind=kind_noahmp) :: RadPhotoActAbsTmp ! temporary absorbed par for leaves [W/m2] + real(kind=kind_noahmp) :: ResistanceStomataTmp ! temporary leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: PhotosynLeafTmp ! temporary leaf photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: NitrogenFoliageFac ! foliage nitrogen adjustment factor (0 to 1) + real(kind=kind_noahmp) :: CarboxylRateMax ! maximum rate of carbonylation [umol co2/m2/s] + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: RLB ! boundary layer resistance [s m2 / umol] + real(kind=kind_noahmp) :: TC ! foliage temperature [deg C] + real(kind=kind_noahmp) :: CS ! co2 concentration at leaf surface [Pa] + real(kind=kind_noahmp) :: KC ! co2 Michaelis-Menten constant [Pa] + real(kind=kind_noahmp) :: KO ! o2 Michaelis-Menten constant [Pa] + real(kind=kind_noahmp) :: A,B,C,Q ! intermediate calculations for RS + real(kind=kind_noahmp) :: R1,R2 ! roots for RS + real(kind=kind_noahmp) :: PPF ! absorb photosynthetic photon flux [umol photons/m2/s] + real(kind=kind_noahmp) :: WC ! Rubisco limited photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: WJ ! light limited photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: WE ! export limited photosynthesis [umol co2/m2/s] + real(kind=kind_noahmp) :: CP ! co2 compensation point [Pa] + real(kind=kind_noahmp) :: CI ! internal co2 [Pa] + real(kind=kind_noahmp) :: AWC ! intermediate calculation for wc + real(kind=kind_noahmp) :: J ! electron transport [umol co2/m2/s] + real(kind=kind_noahmp) :: CEA ! constrain ea or else model blows up + real(kind=kind_noahmp) :: CF ! [s m2/umol] -> [s/m] + real(kind=kind_noahmp) :: T ! temporary var +! local statement functions + real(kind=kind_noahmp) :: F1 ! generic temperature response (statement function) + real(kind=kind_noahmp) :: F2 ! generic temperature inhibition (statement function) + real(kind=kind_noahmp) :: AB ! used in statement functions + real(kind=kind_noahmp) :: BC ! used in statement functions + F1(AB, BC) = AB**( (BC - 25.0) / 10.0 ) + F2(AB) = 1.0 + exp( (-2.2e05 + 710.0 * (AB + 273.16)) / (8.314 * (AB + 273.16)) ) + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + IndexGrowSeason => noahmp%biochem%state%IndexGrowSeason ,& ! in, growing season index (0=off, 1=on) + NitrogenConcFoliage => noahmp%biochem%state%NitrogenConcFoliage ,& ! in, foliage nitrogen concentration [%] + NitrogenConcFoliageMax => noahmp%biochem%param%NitrogenConcFoliageMax ,& ! in, foliage nitrogen concentration when f(n)=1 [%] + QuantumEfficiency25C => noahmp%biochem%param%QuantumEfficiency25C ,& ! in, quantum efficiency at 25c [umol co2 / umol photon] + CarboxylRateMax25C => noahmp%biochem%param%CarboxylRateMax25C ,& ! in, maximum rate of carboxylation at 25c [umol co2/m**2/s] + CarboxylRateMaxQ10 => noahmp%biochem%param%CarboxylRateMaxQ10 ,& ! in, change in maximum rate of carboxylation for each 10C temp change + PhotosynPathC3 => noahmp%biochem%param%PhotosynPathC3 ,& ! in, C3 photosynthetic pathway indicator: 0. = c4, 1. = c3 + SlopeConductToPhotosyn => noahmp%biochem%param%SlopeConductToPhotosyn ,& ! in, slope of conductance-to-photosynthesis relationship + Co2MmConst25C => noahmp%energy%param%Co2MmConst25C ,& ! in, co2 michaelis-menten constant at 25c [Pa] + O2MmConst25C => noahmp%energy%param%O2MmConst25C ,& ! in, o2 michaelis-menten constant at 25c [Pa] + Co2MmConstQ10 => noahmp%energy%param%Co2MmConstQ10 ,& ! in, q10 for Co2MmConst25C + O2MmConstQ10 => noahmp%energy%param%O2MmConstQ10 ,& ! in, q10 for ko25 + ConductanceLeafMin => noahmp%energy%param%ConductanceLeafMin ,& ! in, minimum leaf conductance [umol/m**2/s] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + VapPresSatCanopy => noahmp%energy%state%VapPresSatCanopy ,& ! in, canopy saturation vapor pressure at TV [Pa] + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! in, canopy air vapor pressure [Pa] + PressureAtmosO2 => noahmp%energy%state%PressureAtmosO2 ,& ! in, atmospheric o2 pressure [Pa] + PressureAtmosCO2 => noahmp%energy%state%PressureAtmosCO2 ,& ! in, atmospheric co2 pressure [Pa] + ResistanceLeafBoundary => noahmp%energy%state%ResistanceLeafBoundary ,& ! in, leaf boundary layer resistance [s/m] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! in, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! in, average absorbed par for shaded leaves [W/m2] + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + PhotosynLeafSunlit => noahmp%biochem%flux%PhotosynLeafSunlit ,& ! out, sunlit leaf photosynthesis [umol co2/m2/s] + PhotosynLeafShade => noahmp%biochem%flux%PhotosynLeafShade & ! out, shaded leaf photosynthesis [umol co2/m2/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + + ! initialize ResistanceStomata=maximum value and photosynthesis=0 because will only do calculations + ! for RadPhotoActAbs > 0, in which case ResistanceStomata <= maximum value and photosynthesis >= 0 + CF = PressureAirRefHeight / (8.314 * TemperatureAirRefHeight) * 1.0e06 ! unit conversion factor + ResistanceStomataTmp = 1.0 / ConductanceLeafMin * CF + PhotosynLeafTmp = 0.0 + if ( IndexShade == 0 ) RadPhotoActAbsTmp = RadPhotoActAbsSunlit / max(VegFrac,1.0e-6) ! Sunlit case + if ( IndexShade == 1 ) RadPhotoActAbsTmp = RadPhotoActAbsShade / max(VegFrac,1.0e-6) ! Shaded case + + ! only compute when there is radiation absorption + if ( RadPhotoActAbsTmp > 0.0 ) then + + NitrogenFoliageFac = min(NitrogenConcFoliage/max(MPE, NitrogenConcFoliageMax), 1.0) + TC = TemperatureCanopy - ConstFreezePoint + PPF = 4.6 * RadPhotoActAbsTmp + J = PPF * QuantumEfficiency25C + KC = Co2MmConst25C * F1(Co2MmConstQ10, TC) + KO = O2MmConst25C * F1(O2MmConstQ10, TC) + AWC = KC * ( 1.0 + PressureAtmosO2 / KO ) + CP = 0.5 * KC / KO * PressureAtmosO2 * 0.21 + CarboxylRateMax = CarboxylRateMax25C / F2(TC) * NitrogenFoliageFac * & + SoilTranspFacAcc * F1(CarboxylRateMaxQ10, TC) + ! first guess ci + CI = 0.7 * PressureAtmosCO2 * PhotosynPathC3 + 0.4 * PressureAtmosCO2 * (1.0 - PhotosynPathC3) + ! ResistanceLeafBoundary: s/m -> s m**2 / umol + RLB = ResistanceLeafBoundary / CF + ! constrain PressureVaporCanAir + CEA = max(0.25*VapPresSatCanopy*PhotosynPathC3 + 0.40*VapPresSatCanopy*(1.0-PhotosynPathC3), & + min(PressureVaporCanAir,VapPresSatCanopy)) + + ! ci iteration + do IndIter = 1, NumIter + WJ = max(CI-CP, 0.0) * J / (CI + 2.0*CP) * PhotosynPathC3 + J * (1.0 - PhotosynPathC3) + WC = max(CI-CP, 0.0) * CarboxylRateMax / (CI + AWC) * PhotosynPathC3 + & + CarboxylRateMax * (1.0 - PhotosynPathC3) + WE = 0.5 * CarboxylRateMax * PhotosynPathC3 + & + 4000.0 * CarboxylRateMax * CI / PressureAirRefHeight * (1.0 - PhotosynPathC3) + PhotosynLeafTmp = min(WJ, WC, WE) * IndexGrowSeason + CS = max(PressureAtmosCO2-1.37*RLB*PressureAirRefHeight*PhotosynLeafTmp, MPE) + A = SlopeConductToPhotosyn * PhotosynLeafTmp * PressureAirRefHeight * CEA / & + (CS * VapPresSatCanopy) + ConductanceLeafMin + B = (SlopeConductToPhotosyn * PhotosynLeafTmp * PressureAirRefHeight / CS + ConductanceLeafMin) * & + RLB - 1.0 + C = -RLB + if ( B >= 0.0 ) then + Q = -0.5 * (B + sqrt(B*B-4.0*A*C)) + else + Q = -0.5 * (B - sqrt(B*B-4.0*A*C)) + endif + R1 = Q / A + R2 = C / Q + ResistanceStomataTmp = max(R1, R2) + CI = max(CS-PhotosynLeafTmp*PressureAirRefHeight*1.65*ResistanceStomataTmp, 0.0) + enddo + + ! ResistanceStomata: s m**2 / umol -> s/m + ResistanceStomataTmp = ResistanceStomataTmp * CF + + endif ! RadPhotoActAbsTmp > 0.0 + + ! assign updated values + ! Sunlit case + if ( IndexShade == 0 ) then + ResistanceStomataSunlit = ResistanceStomataTmp + PhotosynLeafSunlit = PhotosynLeafTmp + endif + ! Shaded case + if ( IndexShade == 1 ) then + ResistanceStomataShade = ResistanceStomataTmp + PhotosynLeafShade = PhotosynLeafTmp + endif + + end associate + + end subroutine ResistanceCanopyStomataBallBerry + +end module ResistanceCanopyStomataBallBerryMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataJarvisMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataJarvisMod.F90 new file mode 100644 index 0000000000..39388bd1cb --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceCanopyStomataJarvisMod.F90 @@ -0,0 +1,112 @@ +module ResistanceCanopyStomataJarvisMod + +!!! Compute canopy stomatal resistance and foliage photosynthesis based on Jarvis scheme +!!! Canopy resistance which depends on incoming solar radiation, air temperature, +!!! atmospheric water vapor pressure deficit at the lowest model level, and soil moisture (preferably +!!! unfrozen soil moisture rather than total). +!!! Source: Jarvis (1976), Noilhan and Planton (1989), Jacquemin and Noilhan (1990). +!!! See also Chen et al (1996, JGR, Vol 101(D3), 7251-7268): Eqns 12-14 and Table 2 of Sec. 3.1.2 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use HumiditySaturationMod, only : HumiditySaturation + + implicit none + +contains + + subroutine ResistanceCanopyStomataJarvis(noahmp, IndexShade) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CANRES +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IndexShade ! index for sunlit/shaded (0=sunlit;1=shaded) + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: ResistanceVapDef ! canopy resistance multiplier + real(kind=kind_noahmp) :: ResistanceSolar ! canopy resistance multiplier + real(kind=kind_noahmp) :: ResistanceTemp ! canopy resistance multiplier + real(kind=kind_noahmp) :: RadFac ! solar radiation factor for resistance + real(kind=kind_noahmp) :: SpecHumidityTmp ! specific humidity [kg/kg] + real(kind=kind_noahmp) :: MixingRatioTmp ! mixing ratio [kg/kg] + real(kind=kind_noahmp) :: MixingRatioSat ! saturated mixing ratio [kg/kg] + real(kind=kind_noahmp) :: MixingRatioSatTempD ! d(MixingRatioSat)/d(T) + real(kind=kind_noahmp) :: RadPhotoActAbsTmp ! temporary absorbed par for leaves [W/m2] + real(kind=kind_noahmp) :: ResistanceStomataTmp ! temporary leaf stomatal resistance [s/m] + real(kind=kind_noahmp) :: PhotosynLeafTmp ! temporary leaf photosynthesis [umol co2/m2/s] + +! -------------------------------------------------------------------- + associate( & + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! in, accumulated soil water transpiration factor (0 to 1) + RadiationStressFac => noahmp%energy%param%RadiationStressFac ,& ! in, Parameter used in radiation stress function + ResistanceStomataMin => noahmp%energy%param%ResistanceStomataMin ,& ! in, Minimum stomatal resistance [s m-1] + ResistanceStomataMax => noahmp%energy%param%ResistanceStomataMax ,& ! in, Maximal stomatal resistance [s m-1] + AirTempOptimTransp => noahmp%energy%param%AirTempOptimTransp ,& ! in, Optimum transpiration air temperature [K] + VaporPresDeficitFac => noahmp%energy%param%VaporPresDeficitFac ,& ! in, Parameter used in vapor pressure deficit function + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! in, vegetation temperature [K] + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! in, canopy air vapor pressure [Pa] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! in, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! in, average absorbed par for shaded leaves [W/m2] + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + PhotosynLeafSunlit => noahmp%biochem%flux%PhotosynLeafSunlit ,& ! out, sunlit leaf photosynthesis [umol CO2/m2/s] + PhotosynLeafShade => noahmp%biochem%flux%PhotosynLeafShade & ! out, shaded leaf photosynthesis [umol CO2/m2/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + ResistanceSolar = 0.0 + ResistanceTemp = 0.0 + ResistanceVapDef = 0.0 + ResistanceStomataTmp = 0.0 + if ( IndexShade == 0 ) RadPhotoActAbsTmp = RadPhotoActAbsSunlit / max(VegFrac,1.0e-6) ! Sunlit case + if ( IndexShade == 1 ) RadPhotoActAbsTmp = RadPhotoActAbsShade / max(VegFrac,1.0e-6) ! Shaded case + + ! compute MixingRatioTmp and MixingRatioSat + SpecHumidityTmp = 0.622 * PressureVaporCanAir / (PressureAirRefHeight - 0.378*PressureVaporCanAir) ! specific humidity + MixingRatioTmp = SpecHumidityTmp / (1.0 - SpecHumidityTmp) ! convert to mixing ratio [kg/kg] + call HumiditySaturation(TemperatureCanopy, PressureAirRefHeight, MixingRatioSat, MixingRatioSatTempD) + + ! contribution due to incoming solar radiation + RadFac = 2.0 * RadPhotoActAbsTmp / RadiationStressFac + ResistanceSolar = (RadFac + ResistanceStomataMin/ResistanceStomataMax) / (1.0 + RadFac) + ResistanceSolar = max(ResistanceSolar, 0.0001) + + ! contribution due to air temperature + ResistanceTemp = 1.0 - 0.0016 * ((AirTempOptimTransp - TemperatureCanopy)**2.0) + ResistanceTemp = max(ResistanceTemp, 0.0001) + + ! contribution due to vapor pressure deficit + ResistanceVapDef = 1.0 / (1.0 + VaporPresDeficitFac * max(0.0, MixingRatioSat - MixingRatioTmp)) + ResistanceVapDef = max(ResistanceVapDef, 0.01) + + ! determine canopy resistance due to all factors + ResistanceStomataTmp = ResistanceStomataMin / (ResistanceSolar * ResistanceTemp * ResistanceVapDef * SoilTranspFacAcc) + PhotosynLeafTmp = -999.99 ! photosynthesis not applied for dynamic carbon + + ! assign updated values + ! Sunlit case + if ( IndexShade == 0 ) then + ResistanceStomataSunlit = ResistanceStomataTmp + PhotosynLeafSunlit = PhotosynLeafTmp + endif + ! Shaded case + if ( IndexShade == 1 ) then + ResistanceStomataShade = ResistanceStomataTmp + PhotosynLeafShade = PhotosynLeafTmp + endif + + end associate + + end subroutine ResistanceCanopyStomataJarvis + +end module ResistanceCanopyStomataJarvisMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationGlacierMod.F90 new file mode 100644 index 0000000000..389536f642 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationGlacierMod.F90 @@ -0,0 +1,44 @@ +module ResistanceGroundEvaporationGlacierMod + +!!! Compute glacier surface resistance to ground evaporation/sublimation +!!! It represents the resistance imposed by the molecular diffusion in +!!! surface (as opposed to aerodynamic resistance computed elsewhere in the model) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceGroundEvaporationGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variables + +! -------------------------------------------------------------------- + associate( & + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! out, ground surface resistance [s/m] to evaporation + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd & ! out, raltive humidity in surface glacier/snow air space + ) +! ---------------------------------------------------------------------- + + ResistanceGrdEvap = 1.0 + RelHumidityGrd = 1.0 + + end associate + + end subroutine ResistanceGroundEvaporationGlacier + +end module ResistanceGroundEvaporationGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationMod.F90 new file mode 100644 index 0000000000..13a48b63ab --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceGroundEvaporationMod.F90 @@ -0,0 +1,101 @@ +module ResistanceGroundEvaporationMod + +!!! Compute soil surface resistance to ground evaporation/sublimation +!!! It represents the resistance imposed by the molecular diffusion in soil +!!! surface (as opposed to aerodynamic resistance computed elsewhere in the model) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceGroundEvaporation(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variables + real(kind=kind_noahmp) :: SoilEvapFac ! soil water evaporation factor (0- 1) + real(kind=kind_noahmp) :: DrySoilThickness ! Dry-layer thickness [m] for computing RSURF (Sakaguchi and Zeng, 2009) + real(kind=kind_noahmp) :: VapDiffuseRed ! Reduced vapor diffusivity [m2/s] in soil for computing RSURF (SZ09) + real(kind=kind_noahmp) :: SoilMatPotentialSfc ! surface layer soil matric potential [m] + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + OptGroundResistanceEvap => noahmp%config%nmlist%OptGroundResistanceEvap ,& ! in, options for ground resistance to evaporation/sublimation + ResistanceSoilExp => noahmp%energy%param%ResistanceSoilExp ,& ! in, exponent in the shape parameter for soil resistance + ResistanceSnowSfc => noahmp%energy%param%ResistanceSnowSfc ,& ! in, surface resistance for snow [s/m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! out, ground surface resistance [s/m] to evaporation + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd & ! out, raltive humidity in surface soil/snow air space + ) +! ---------------------------------------------------------------------- + + ! initialization + SoilEvapFac = max(0.0, SoilLiqWater(1)/SoilMoistureSat(1)) + + if ( SurfaceType == 2 ) then ! lake point + ResistanceGrdEvap = 1.0 ! avoid being divided by 0 + RelHumidityGrd = 1.0 + else ! soil point + ! Sakaguchi and Zeng, 2009 + if ( (OptGroundResistanceEvap == 1) .or. (OptGroundResistanceEvap == 4) ) then + DrySoilThickness = (-DepthSoilLayer(1)) * (exp((1.0 - min(1.0,SoilLiqWater(1)/SoilMoistureSat(1))) ** & + ResistanceSoilExp) - 1.0) / (2.71828-1.0) + VapDiffuseRed = 2.2e-5 * SoilMoistureSat(1) * SoilMoistureSat(1) * & + (1.0 - SoilMoistureWilt(1)/SoilMoistureSat(1)) ** (2.0 + 3.0/SoilExpCoeffB(1)) + ResistanceGrdEvap = DrySoilThickness / VapDiffuseRed + + ! Sellers (1992) original + elseif ( OptGroundResistanceEvap == 2 ) then + ResistanceGrdEvap = SnowCoverFrac * 1.0 + (1.0 - SnowCoverFrac) * exp(8.25 - 4.225*SoilEvapFac) + + ! Sellers (1992) adjusted to decrease ResistanceGrdEvap for wet soil + elseif ( OptGroundResistanceEvap == 3 ) then + ResistanceGrdEvap = SnowCoverFrac * 1.0 + (1.0 - SnowCoverFrac) * exp(8.25 - 6.0*SoilEvapFac) + endif + + ! SnowCoverFrac weighted; snow ResistanceGrdEvap set in MPTABLE v3.8 + if ( OptGroundResistanceEvap == 4 ) then + ResistanceGrdEvap = 1.0 / (SnowCoverFrac * (1.0/ResistanceSnowSfc) + & + (1.0-SnowCoverFrac) * (1.0/max(ResistanceGrdEvap,0.001))) + endif + if ( (SoilLiqWater(1) < 0.01) .and. (SnowDepth == 0.0) ) ResistanceGrdEvap = 1.0e6 + + SoilMatPotentialSfc = -SoilMatPotentialSat(1) * & + (max(0.01,SoilLiqWater(1)) / SoilMoistureSat(1)) ** (-SoilExpCoeffB(1)) + RelHumidityGrd = SnowCoverFrac + & + (1.0-SnowCoverFrac) * exp(SoilMatPotentialSfc*ConstGravityAcc/(ConstGasWaterVapor*TemperatureGrd)) + endif + + ! urban + if ( (FlagUrban .eqv. .true.) .and. (SnowDepth == 0.0) ) then + ResistanceGrdEvap = 1.0e6 + endif + + end associate + + end subroutine ResistanceGroundEvaporation + +end module ResistanceGroundEvaporationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ResistanceLeafToGroundMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceLeafToGroundMod.F90 new file mode 100644 index 0000000000..8f2811d6d0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ResistanceLeafToGroundMod.F90 @@ -0,0 +1,106 @@ +module ResistanceLeafToGroundMod + +!!! Compute under-canopy aerodynamic resistance and leaf boundary layer resistance + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ResistanceLeafToGround(noahmp, IndIter, VegAreaIndEff, HeatSenGrdTmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RAGRB +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + integer , intent(in ) :: IndIter ! iteration index + real(kind=kind_noahmp), intent(in ) :: HeatSenGrdTmp ! temporary ground sensible heat flux (w/m2) in each iteration + real(kind=kind_noahmp), intent(in ) :: VegAreaIndEff ! temporary effective vegetation area index with constraint (<=6.0) + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: MPE ! prevents overflow for division by zero + real(kind=kind_noahmp) :: KH ! turbulent transfer coefficient, sensible heat, (m2/s) + real(kind=kind_noahmp) :: TMP1 ! temporary calculation + real(kind=kind_noahmp) :: TMP2 ! temporary calculation + real(kind=kind_noahmp) :: TMPRAH2 ! temporary calculation for aerodynamic resistances + real(kind=kind_noahmp) :: TMPRB ! temporary calculation for rb + real(kind=kind_noahmp) :: FHGNEW ! temporary vars + +! -------------------------------------------------------------------- + associate( & + LeafDimLength => noahmp%energy%param%LeafDimLength ,& ! in, characteristic leaf dimension [m] + CanopyWindExtFac => noahmp%energy%param%CanopyWindExtFac ,& ! in, canopy wind extinction parameter + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + TemperatureCanopyAir => noahmp%energy%state%TemperatureCanopyAir ,& ! in, canopy air temperature [K] + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! in, zero plane displacement [m] + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + CanopyHeight => noahmp%energy%state%CanopyHeight ,& ! in, canopy height [m] + WindSpdCanopyTop => noahmp%energy%state%WindSpdCanopyTop ,& ! in, wind speed at top of canopy [m/s] + RoughLenShCanopy => noahmp%energy%state%RoughLenShCanopy ,& ! in, roughness length [m], sensible heat, canopy + RoughLenShVegGrd => noahmp%energy%state%RoughLenShVegGrd ,& ! in, roughness length [m], sensible heat ground, below canopy + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! in, friction velocity [m/s], vegetated + MoStabCorrShUndCan => noahmp%energy%state%MoStabCorrShUndCan ,& ! inout, stability correction ground, below canopy + WindExtCoeffCanopy => noahmp%energy%state%WindExtCoeffCanopy ,& ! out, canopy wind extinction coefficient + MoStabParaUndCan => noahmp%energy%state%MoStabParaUndCan ,& ! out, Monin-Obukhov stability parameter ground, below canopy + MoLengthUndCan => noahmp%energy%state%MoLengthUndCan ,& ! out, Monin-Obukhov length [m], ground, below canopy + ResistanceMomUndCan => noahmp%energy%state%ResistanceMomUndCan ,& ! out, ground aerodynamic resistance for momentum [s/m] + ResistanceShUndCan => noahmp%energy%state%ResistanceShUndCan ,& ! out, ground aerodynamic resistance for sensible heat [s/m] + ResistanceLhUndCan => noahmp%energy%state%ResistanceLhUndCan ,& ! out, ground aerodynamic resistance for water vapor [s/m] + ResistanceLeafBoundary => noahmp%energy%state%ResistanceLeafBoundary & ! out, bulk leaf boundary layer resistance [s/m] + ) +! ---------------------------------------------------------------------- + + ! initialization + MPE = 1.0e-6 + MoStabParaUndCan = 0.0 + MoLengthUndCan = 0.0 + + ! stability correction to below canopy resistance + if ( IndIter > 1 ) then + TMP1 = ConstVonKarman * (ConstGravityAcc / TemperatureCanopyAir) * HeatSenGrdTmp / & + (DensityAirRefHeight * ConstHeatCapacAir) + if ( abs(TMP1) <= MPE ) TMP1 = MPE + MoLengthUndCan = -1.0 * FrictionVelVeg**3 / TMP1 + MoStabParaUndCan = min((ZeroPlaneDispSfc-RoughLenMomGrd)/MoLengthUndCan, 1.0) + endif + if ( MoStabParaUndCan < 0.0 ) then + FHGNEW = (1.0 - 15.0 * MoStabParaUndCan)**(-0.25) + else + FHGNEW = 1.0 + 4.7 * MoStabParaUndCan + endif + if ( IndIter == 1 ) then + MoStabCorrShUndCan = FHGNEW + else + MoStabCorrShUndCan = 0.5 * (MoStabCorrShUndCan + FHGNEW) + endif + + ! wind attenuation within canopy + WindExtCoeffCanopy = (CanopyWindExtFac * VegAreaIndEff * CanopyHeight * MoStabCorrShUndCan)**0.5 + TMP1 = exp(-WindExtCoeffCanopy * RoughLenShVegGrd / CanopyHeight) + TMP2 = exp(-WindExtCoeffCanopy * (RoughLenShCanopy + ZeroPlaneDispSfc) / CanopyHeight) + TMPRAH2 = CanopyHeight * exp(WindExtCoeffCanopy) / WindExtCoeffCanopy * (TMP1-TMP2) + + ! aerodynamic resistances raw and rah between heights ZeroPlaneDisp+RoughLenShVegGrd and RoughLenShVegGrd. + KH = max(ConstVonKarman*FrictionVelVeg*(CanopyHeight-ZeroPlaneDispSfc), MPE) + ResistanceMomUndCan = 0.0 + ResistanceShUndCan = TMPRAH2 / KH + ResistanceLhUndCan = ResistanceShUndCan + + ! leaf boundary layer resistance + TMPRB = WindExtCoeffCanopy * 50.0 / (1.0 - exp(-WindExtCoeffCanopy/2.0)) + ResistanceLeafBoundary = TMPRB * sqrt(LeafDimLength / WindSpdCanopyTop) + ResistanceLeafBoundary = min(max(ResistanceLeafBoundary, 5.0), 50.0) ! limit ResistanceLeafBoundary to 5-50, typically <50 + + end associate + + end subroutine ResistanceLeafToGround + +end module ResistanceLeafToGroundMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceDrainageMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceDrainageMod.F90 new file mode 100644 index 0000000000..495756a2a4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceDrainageMod.F90 @@ -0,0 +1,39 @@ +module RunoffSubSurfaceDrainageMod + +!!! Calculate subsurface runoff using derived soil water drainage rate + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSubSurfaceDrainage(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in WATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! in, soil bottom drainage [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! inout, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! compuate subsurface runoff mm/s + RunoffSubsurface = RunoffSubsurface + DrainSoilBot + + end associate + + end subroutine RunoffSubSurfaceDrainage + +end module RunoffSubSurfaceDrainageMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceEquiWaterTableMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceEquiWaterTableMod.F90 new file mode 100644 index 0000000000..fa87cba82f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceEquiWaterTableMod.F90 @@ -0,0 +1,52 @@ +module RunoffSubSurfaceEquiWaterTableMod + +!!! Calculate subsurface runoff using equilibrium water table depth (Niu et al., 2005) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use WaterTableEquilibriumMod, only : WaterTableEquilibrium + + implicit none + +contains + + subroutine RunoffSubSurfaceEquiWaterTable(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! in, maximum soil imperviousness fraction + GridTopoIndex => noahmp%water%param%GridTopoIndex ,& ! in, gridcell mean topgraphic index (global mean) + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [m-1] + BaseflowCoeff => noahmp%water%param%BaseflowCoeff ,& ! inout, baseflow coefficient [mm/s] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! out, water table depth [m] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! out, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! set parameter values specific for this scheme + RunoffDecayFac = 2.0 + BaseflowCoeff = 4.0 + + ! compute equilibrium water table depth + call WaterTableEquilibrium(noahmp) + + ! compuate subsurface runoff mm/s + RunoffSubsurface = (1.0 - SoilImpervFracMax) * BaseflowCoeff * & + exp(-GridTopoIndex) * exp(-RunoffDecayFac * WaterTableDepth) + + end associate + + end subroutine RunoffSubSurfaceEquiWaterTable + +end module RunoffSubSurfaceEquiWaterTableMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceGroundWaterMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceGroundWaterMod.F90 new file mode 100644 index 0000000000..7659c7e5ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceGroundWaterMod.F90 @@ -0,0 +1,43 @@ +module RunoffSubSurfaceGroundWaterMod + +!!! Calculate subsurface runoff based on TOPMODEL with groundwater (Niu et al 2007) + + use Machine + use NoahmpVarType + use ConstantDefineMod + use GroundWaterTopModelMod, only : GroundWaterTopModel + + implicit none + +contains + + subroutine RunoffSubSurfaceGroundWater(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in WATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + DischargeGw => noahmp%water%flux%DischargeGw ,& ! out, groundwater discharge [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! out, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! compute ground water + call GroundWaterTopModel(noahmp) + + ! compute subsurface runoff as groundwater discharge + RunoffSubsurface = DischargeGw + + end associate + + end subroutine RunoffSubSurfaceGroundWater + +end module RunoffSubSurfaceGroundWaterMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceShallowMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceShallowMmfMod.F90 new file mode 100644 index 0000000000..302f8c79bc --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSubSurfaceShallowMmfMod.F90 @@ -0,0 +1,52 @@ +module RunoffSubSurfaceShallowMmfMod + +!!! Calculate subsurface runoff based on MMF groundwater scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + use ShallowWaterTableMmfMod, only : ShallowWaterTableMMF + + implicit none + +contains + + subroutine RunoffSubSurfaceShallowWaterMMF(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in WATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! in, soil bottom drainage [mm/s] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil water content [m3/m3] + WaterStorageAquifer => noahmp%water%state%WaterStorageAquifer ,& ! inout, water storage in aquifer [mm] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface & ! out, subsurface runoff [mm/s] + ) +! ---------------------------------------------------------------------- + + ! compute shallow water table and moisture + call ShallowWaterTableMMF(noahmp) + + ! update moisture + SoilLiqWater(NumSoilLayer) = SoilMoisture(NumSoilLayer) - SoilIce(NumSoilLayer) + + ! compute subsurface runoff + RunoffSubsurface = RunoffSubsurface + DrainSoilBot + WaterStorageAquifer = 0.0 + + end associate + + end subroutine RunoffSubSurfaceShallowWaterMMF + +end module RunoffSubSurfaceShallowMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceBatsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceBatsMod.F90 new file mode 100644 index 0000000000..1b9204b7e0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceBatsMod.F90 @@ -0,0 +1,68 @@ +module RunoffSurfaceBatsMod + +!!! Calculate surface runoff based on BATS scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceBATS(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: SoilMoistureTmp ! 2-m averaged soil moisture (m3/m3) + real(kind=kind_noahmp) :: SoilDepthTmp ! 2-m soil depth (m) + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil water content [m3/m3] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + SoilMoistureTmp = 0.0 + SoilDepthTmp = 0.0 + + ! compute mean soil moisture, depth and saturation fraction + do LoopInd = 1, NumSoilLayer + SoilDepthTmp = SoilDepthTmp + ThicknessSnowSoilLayer(LoopInd) + SoilMoistureTmp = SoilMoistureTmp + & + SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) * ThicknessSnowSoilLayer(LoopInd) + if ( SoilDepthTmp >= 2.0 ) exit + enddo + SoilMoistureTmp = SoilMoistureTmp / SoilDepthTmp + SoilSaturateFrac = max(0.01, SoilMoistureTmp)**4.0 ! BATS + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceBATS + +end module RunoffSurfaceBatsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceDynamicVicMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceDynamicVicMod.F90 new file mode 100644 index 0000000000..d9f75e40ba --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceDynamicVicMod.F90 @@ -0,0 +1,300 @@ +module RunoffSurfaceDynamicVicMod + +!!! Compuate inflitration rate at soil surface and estimate surface runoff based on dynamic VIC scheme +!!! Reference: Liang, X., & Xie, Z. (2001). A new surface runoff parameterization with subgrid-scale +!!! soil heterogeneity for land surface models. Advances in Water Resources, 24(9-10), 1173-1193. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilWaterInfilPhilipMod, only : SoilWaterInfilPhilip + use SoilWaterInfilGreenAmptMod, only : SoilWaterInfilGreenAmpt + use SoilWaterInfilSmithParlangeMod, only : SoilWaterInfilSmithParlange + use RunoffSurfaceExcessDynamicVicMod + + implicit none + +contains + + subroutine RunoffSurfaceDynamicVic(noahmp, TimeStep, InfilRateAcc) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: DYNAMIC_VIC +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), intent(inout) :: InfilRateAcc ! accumulated infiltration rate (m/s) + +! local variable + integer :: IndIter ! iteration index + integer :: NumIter ! number of interation + integer :: IndInfilMax ! index to check maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp) :: InfilExpB ! B parameter for infiltration scaling curve + real(kind=kind_noahmp) :: WaterDepthTop ! actual water depth in top layers [m] + real(kind=kind_noahmp) :: WaterDepthSatTop ! saturated water depth in top layers [m] + real(kind=kind_noahmp) :: WaterInSoilSfc ! water input on soil surface [m] + real(kind=kind_noahmp) :: WaterDepthInit ! initial water depth [m] + real(kind=kind_noahmp) :: WaterDepthMax ! maximum water depth [m] + real(kind=kind_noahmp) :: InfilSfcTmp ! surface infiltration rate [m/s] + real(kind=kind_noahmp) :: InfilSfcMax ! maximum infiltration rate [m/s] + real(kind=kind_noahmp) :: RunoffSatExcess ! saturation excess runoff [m/s] + real(kind=kind_noahmp) :: RunoffInfilExcess ! infiltration excess runoff [m/s] + real(kind=kind_noahmp) :: InfilTmp ! infiltration [m/s] + real(kind=kind_noahmp) :: RunoffSatExcTmp ! temporary saturation excess runoff [m/s] + real(kind=kind_noahmp) :: RunoffInfExcTmp ! temporary infiltration excess runoff [m/s] + real(kind=kind_noahmp) :: RunoffSatExcTmp1 ! saturation excess runoff [m/s] + real(kind=kind_noahmp) :: DepthYTmp ! temporary depth Y [m] + real(kind=kind_noahmp) :: DepthYPrev ! previous depth Y [m] + real(kind=kind_noahmp) :: DepthYInit ! initial depth Y [m] + real(kind=kind_noahmp) :: TmpVar1 ! temporary variable + real(kind=kind_noahmp) :: Error ! allowed error + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + OptDynVicInfiltration => noahmp%config%nmlist%OptDynVicInfiltration ,& ! in, options for infiltration in dynamic VIC runoff scheme + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + InfilHeteroDynVic => noahmp%water%param%InfilHeteroDynVic ,& ! in, Dynamic VIC heterogeniety parameter for infiltration + InfilFacDynVic => noahmp%water%param%InfilFacDynVic ,& ! in, Dynamic VIC model infiltration parameter + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + WaterDepthTop = 0.0 + WaterDepthSatTop = 0.0 + InfilExpB = 1.0 + WaterInSoilSfc = 0.0 + WaterDepthMax = 0.0 + WaterDepthInit = 0.0 + RunoffSatExcess = 0.0 + RunoffInfilExcess = 0.0 + InfilTmp = 0.0 + RunoffSurface = 0.0 + InfilRateSfc = 0.0 + NumIter = 20 + Error = 1.388889E-07 * TimeStep ! 0.5 mm per hour time step + InfilExpB = InfilHeteroDynVic + + do IndIter = 1, NumSoilLayer-2 + WaterDepthTop = WaterDepthTop + (SoilMoisture(IndIter) * (-1.0) * DepthSoilLayer(IndIter)) ! actual moisture in top layers, [m] + WaterDepthSatTop = WaterDepthSatTop + (SoilMoistureSat(IndIter) * (-1.0) * DepthSoilLayer(IndIter)) ! maximum moisture in top layers, [m] + enddo + if ( WaterDepthTop > WaterDepthSatTop ) WaterDepthTop = WaterDepthSatTop + + WaterInSoilSfc = SoilSfcInflowMean * TimeStep ! precipitation depth, [m] + WaterDepthMax = WaterDepthSatTop * (InfilFacDynVic + 1.0) ! maximum infiltration capacity [m], Eq.14 + WaterDepthInit = WaterDepthMax * (1.0 - (1.0 - (WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) ! infiltration capacity, [m] in Eq.1 + !WaterDepthMax = CAP_minf ; WaterDepthInit = A + IndInfilMax = 0 + + ! compute surface infiltration + if ( OptDynVicInfiltration == 1 ) then + call SoilWaterInfilPhilip(noahmp, TimeStep, IndInfilMax, InfilRateAcc, InfilSfcTmp) + else if ( OptDynVicInfiltration == 2 ) then + call SoilWaterInfilGreenAmpt(noahmp, IndInfilMax, InfilRateAcc, InfilSfcTmp) + else if ( OptDynVicInfiltration == 3 ) then + call SoilWaterInfilSmithParlange(noahmp, IndInfilMax, InfilRateAcc, InfilSfcTmp) + endif + + ! I_MM = InfilSfcTmp; I_M = InfilSfcMax + InfilSfcMax = (InfilExpB + 1.0) * InfilSfcTmp + if ( WaterInSoilSfc <= 0.0 ) then + RunoffSatExcess = 0.0 + RunoffInfilExcess = 0.0 + InfilTmp = 0.0 + goto 2001 + else + if ( (WaterDepthTop >= WaterDepthSatTop) .and. (WaterDepthInit >= WaterDepthMax) ) then + WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax + RunoffSatExcess = WaterInSoilSfc + RunoffInfilExcess = 0.0 + InfilTmp = 0.0 + goto 2001 + else + WaterDepthInit = WaterDepthMax * (1.0-(1.0-(WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) + if ( (WaterInSoilSfc+WaterDepthInit) > WaterDepthMax ) then + if ( (InfilSfcMax*TimeStep) >= WaterInSoilSfc) then + DepthYTmp = WaterDepthMax - WaterDepthInit + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + TmpVar1 = WaterDepthMax - WaterDepthInit - RunoffSatExcTmp - (InfilSfcTmp*TimeStep) * & + (1.0-(1.0-((WaterInSoilSfc-RunoffSatExcTmp)/(InfilSfcMax*TimeStep))**(InfilExpB+1.0))) + if ( TmpVar1 <= 0.0 ) then + DepthYTmp = WaterDepthMax - WaterDepthInit + InfilTmp = WaterDepthSatTop - WaterDepthTop + RunoffSatExcess = WaterInSoilSfc - InfilTmp + RunoffInfilExcess = 0.0 + WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax + goto 2001 + else + DepthYTmp = 0.0 + do IndIter = 1, NumIter ! loop : iteration 1 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp + ((InfilSfcTmp*TimeStep) * & + (1.0-(1.0-((WaterInSoilSfc-RunoffSatExcTmp)/(InfilSfcMax*TimeStep))**(InfilExpB+1.0)))) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1003 + endif + enddo + endif + else + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + if ( (RunoffSatExcTmp+(InfilSfcMax*TimeStep)) <= WaterInSoilSfc ) then + if ( (WaterDepthMax-WaterDepthInit-RunoffSatExcTmp-(InfilSfcMax*TimeStep)) <= 0.0 ) then + DepthYTmp = WaterDepthMax - WaterDepthInit + InfilTmp = WaterDepthSatTop - WaterDepthTop + RunoffSatExcess = WaterInSoilSfc - InfilTmp + RunoffInfilExcess = 0.0 + WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax + goto 2001 + else + DepthYTmp = 0.0 + do IndIter = 1, NumIter ! loop : iteration 2 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp + (InfilSfcTmp*TimeStep) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1003 + endif + enddo + endif + else + DepthYTmp = WaterInSoilSfc / 2.0 + do IndIter = 1, NumIter ! loop : iteration 3_0 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = DepthYTmp - RunoffSatExcTmp - (InfilSfcTmp*TimeStep) + WaterInSoilSfc + if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + DepthYInit = DepthYTmp + exit + endif + enddo + do IndIter = 1, NumIter ! loop : iteration 3 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + RunoffInfExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + call RunoffInfilExcessDynamicVic(DepthYTmp,DepthYInit,RunoffSatExcTmp,InfilSfcMax,& + InfilSfcTmp,TimeStep,WaterInSoilSfc,InfilExpB,RunoffInfExcTmp) + DepthYTmp = WaterInSoilSfc - RunoffInfExcTmp + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1003 + endif + enddo +1003 if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp1) + RunoffSatExcess = RunoffSatExcTmp1 + RunoffInfilExcess = WaterInSoilSfc - DepthYTmp + InfilTmp = DepthYTmp - RunoffSatExcess + WaterDepthTop = WaterDepthTop + InfilTmp + DepthYTmp = WaterDepthInit + DepthYTmp + if ( WaterDepthTop <= 0.0 ) WaterDepthTop = 0.0 + if ( WaterDepthTop >= WaterDepthSatTop ) WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax * (1.0-(1.0-(WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) + goto 2001 + endif + endif + else + if ( (InfilSfcMax*TimeStep) >= WaterInSoilSfc) then + DepthYTmp = WaterInSoilSfc / 2.0 + do IndIter = 1, NumIter ! iteration 1 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp + ((InfilSfcTmp*TimeStep) * & + (1.0-(1.0-((WaterInSoilSfc-RunoffSatExcTmp)/(InfilSfcMax*TimeStep))**(InfilExpB+1.0)))) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1004 + endif + enddo + else + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + if ( (RunoffSatExcTmp+(InfilSfcMax*TimeStep)) <= WaterInSoilSfc ) then + DepthYTmp = WaterInSoilSfc / 2.0 + do IndIter = 1, NumIter ! iteration 2 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = RunoffSatExcTmp+(InfilSfcTmp*TimeStep) + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1004 + endif + enddo + else + DepthYTmp = 0.0 + do IndIter = 1, NumIter ! iteration 3_0 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + DepthYTmp = (WaterInSoilSfc - (InfilSfcMax*TimeStep)) + DepthYTmp - RunoffSatExcTmp + if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + RunoffSatExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + if ( (abs(RunoffSatExcTmp+(InfilSfcMax*TimeStep)-WaterInSoilSfc) <= Error) .or. (IndIter == NumIter) ) then + DepthYInit = DepthYTmp + exit + endif + enddo + do IndIter = 1, NumIter ! iteration 3 + DepthYPrev = DepthYTmp + RunoffSatExcTmp = 0.0 + RunoffInfExcTmp = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp) + call RunoffInfilExcessDynamicVic(DepthYTmp,DepthYInit,RunoffSatExcTmp,InfilSfcMax,& + InfilSfcTmp,TimeStep,WaterInSoilSfc,InfilExpB,RunoffInfExcTmp) + DepthYTmp = WaterInSoilSfc - RunoffInfExcTmp + if ( (abs(DepthYTmp-DepthYPrev) <= Error) .or. (IndIter == NumIter) ) then + goto 1004 + endif + enddo + endif + endif +1004 if ( DepthYTmp <= 0.0 ) DepthYTmp = 0.0 + if ( DepthYTmp >= WaterInSoilSfc ) DepthYTmp = WaterInSoilSfc + RunoffSatExcTmp1 = 0.0 + call RunoffSatExcessDynamicVic(noahmp,WaterDepthInit,WaterDepthMax,DepthYTmp,RunoffSatExcTmp1) + RunoffSatExcess = RunoffSatExcTmp1 + RunoffInfilExcess = WaterInSoilSfc - DepthYTmp + InfilTmp = DepthYTmp - RunoffSatExcess + WaterDepthTop = WaterDepthTop + InfilTmp + if ( WaterDepthTop <= 0.0 ) WaterDepthTop = 0.0 + if ( WaterDepthTop >= WaterDepthSatTop ) WaterDepthTop = WaterDepthSatTop + WaterDepthInit = WaterDepthMax * (1.0-(1.0-(WaterDepthTop/WaterDepthSatTop)**(1.0/(1.0+InfilFacDynVic)))) + endif + endif + endif + +2001 RunoffSurface = (RunoffSatExcess + RunoffInfilExcess) / TimeStep + RunoffSurface = min(RunoffSurface, SoilSfcInflowMean) + RunoffSurface = max(RunoffSurface, 0.0) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + end associate + + end subroutine RunoffSurfaceDynamicVic + +end module RunoffSurfaceDynamicVicMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceExcessDynamicVicMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceExcessDynamicVicMod.F90 new file mode 100644 index 0000000000..910a86f277 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceExcessDynamicVicMod.F90 @@ -0,0 +1,88 @@ +module RunoffSurfaceExcessDynamicVicMod + +!!! Compute infiltration and saturation excess runoff for dyanmic VIC runoff scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSatExcessDynamicVic(noahmp, WaterDepthInit, WaterDepthMax, DepthYTmp, RunoffSatExcess) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: RR1 for saturation excess runoff +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: WaterDepthInit ! initial water depth [m] + real(kind=kind_noahmp), intent(in) :: WaterDepthMax ! maximum water depth [m] + real(kind=kind_noahmp), intent(in) :: DepthYTmp ! initial depth Y [m] + real(kind=kind_noahmp), intent(out) :: RunoffSatExcess ! saturation excess runoff [m/s] + +! local variable + real(kind=kind_noahmp) :: WaterTableDepth ! water table depth [m] + +! ------------------------------------------------------------------ + associate( & + InfilFacDynVic => noahmp%water%param%InfilFacDynVic & ! in, DVIC model infiltration parameter + ) +! ------------------------------------------------------------------ + + WaterTableDepth = WaterDepthInit + DepthYTmp + if ( WaterTableDepth > WaterDepthMax ) WaterTableDepth = WaterDepthMax + + ! Saturation excess runoff , Eq 5. + RunoffSatExcess = DepthYTmp - ((WaterDepthMax/(InfilFacDynVic+1.0)) * & + (((1.0 - (WaterDepthInit/WaterDepthMax))**(InfilFacDynVic+1.0)) & + - ((1.0 - (WaterTableDepth/WaterDepthMax))**(InfilFacDynVic+1.0)))) + + if ( RunoffSatExcess < 0.0 ) RunoffSatExcess = 0.0 + + end associate + + end subroutine RunoffSatExcessDynamicVic + + + subroutine RunoffInfilExcessDynamicVic(DepthYTmp, DepthYInit, RunoffSatExcess, InfilRateMax, & + InfilRateSfc, TimeStep, WaterInSoilSfc, InfilExpB, RunoffInfilExcess) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: RRunoffInfilExcess for infiltration excess runoff +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + real(kind=kind_noahmp), intent(in) :: DepthYTmp ! initial depth Y [m] + real(kind=kind_noahmp), intent(in) :: DepthYInit ! initial depth Y [m] + real(kind=kind_noahmp), intent(in) :: RunoffSatExcess ! saturation excess runoff [m/s] + real(kind=kind_noahmp), intent(in) :: InfilRateMax ! maximum infiltration rate [m/s] + real(kind=kind_noahmp), intent(in) :: InfilRateSfc ! surface infiltration rate [m/s] + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), intent(in) :: WaterInSoilSfc ! water input on soil surface [m] + real(kind=kind_noahmp), intent(in) :: InfilExpB ! B parameter for infiltration scaling curve + real(kind=kind_noahmp), intent(out) :: RunoffInfilExcess ! infiltration excess runoff [m/s] +! ---------------------------------------------------------------------- + + if ( DepthYTmp >= DepthYInit ) then + RunoffInfilExcess = WaterInSoilSfc - RunoffSatExcess - (InfilRateMax * TimeStep * & + (1.0-((1.0-(WaterInSoilSfc-RunoffSatExcess)/(InfilRateMax*TimeStep))**(InfilExpB+1.0)))) + else + RunoffInfilExcess = WaterInSoilSfc - RunoffSatExcess - (InfilRateMax*TimeStep) + endif + + if ( RunoffInfilExcess < 0.0) RunoffInfilExcess =0.0 + + end subroutine RunoffInfilExcessDynamicVic + +end module RunoffSurfaceExcessDynamicVicMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceFreeDrainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceFreeDrainMod.F90 new file mode 100644 index 0000000000..e2e28450e7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceFreeDrainMod.F90 @@ -0,0 +1,132 @@ +module RunoffSurfaceFreeDrainMod + +!!! Calculate inflitration rate at soil surface and surface runoff for free drainage scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine RunoffSurfaceFreeDrain(noahmp, TimeStep) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: INFIL +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + +! local variable + integer :: IndSoilFrz ! number of interaction + integer :: LoopInd1, LoopInd2, LoopInd3 ! do-loop index + integer, parameter :: FrzSoilFac = 3 ! frozen soil pre-factor + real(kind=kind_noahmp) :: FracVoidRem ! remaining fraction + real(kind=kind_noahmp) :: SoilWatHoldMaxRem ! remaining accumulated maximum holdable soil water [m] + real(kind=kind_noahmp) :: WaterInSfc ! surface in water [m] + real(kind=kind_noahmp) :: TimeStepDay ! time indices + real(kind=kind_noahmp) :: SoilWatHoldMaxAcc ! accumulated maximum holdable soil water [m] + real(kind=kind_noahmp) :: SoilIceWatTmp ! maximum soil ice water [m] + real(kind=kind_noahmp) :: SoilImpervFrac ! impervious fraction due to frozen soil + real(kind=kind_noahmp) :: IndAcc ! accumulation index + real(kind=kind_noahmp) :: SoilIceCoeff ! soil ice coefficient + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: SoilWatHoldCap ! soil moisture holding capacity [m3/m3] + real(kind=kind_noahmp) :: InfilRateMax ! maximum infiltration rate [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatMaxHold ! maximum soil water that can hold [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilIceMax => noahmp%water%state%SoilIceMax ,& ! in, maximum soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilInfilMaxCoeff => noahmp%water%param%SoilInfilMaxCoeff ,& ! in, parameter to calculate maximum infiltration rate + SoilImpervFracCoeff => noahmp%water%param%SoilImpervFracCoeff ,& ! in, parameter to calculate frozen soil impermeable fraction + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialize + if (.not. allocated(SoilWatMaxHold)) allocate(SoilWatMaxHold(1:NumSoilLayer)) + SoilWatMaxHold(1:NumSoilLayer) = 0.0 + + ! start infiltration for free drainage scheme + if ( SoilSfcInflowMean > 0.0 ) then + + TimeStepDay = TimeStep / 86400.0 + SoilWatHoldCap = SoilMoistureSat(1) - SoilMoistureWilt(1) + + ! compute maximum infiltration rate + SoilWatMaxHold(1) = -DepthSoilLayer(1) * SoilWatHoldCap + SoilIceWatTmp = -DepthSoilLayer(1) * SoilIce(1) + SoilWatMaxHold(1) = SoilWatMaxHold(1) * (1.0-(SoilLiqWater(1)+SoilIce(1)-SoilMoistureWilt(1)) / SoilWatHoldCap) + SoilWatHoldMaxAcc = SoilWatMaxHold(1) + do LoopInd3 = 2, NumSoilLayer + SoilIceWatTmp = SoilIceWatTmp + (DepthSoilLayer(LoopInd3-1) - DepthSoilLayer(LoopInd3))*SoilIce(LoopInd3) + SoilWatMaxHold(LoopInd3) = (DepthSoilLayer(LoopInd3-1) - DepthSoilLayer(LoopInd3)) * SoilWatHoldCap + SoilWatMaxHold(LoopInd3) = SoilWatMaxHold(LoopInd3) * (1.0 - (SoilLiqWater(LoopInd3) + SoilIce(LoopInd3) - & + SoilMoistureWilt(LoopInd3)) / SoilWatHoldCap) + SoilWatHoldMaxAcc = SoilWatHoldMaxAcc + SoilWatMaxHold(LoopInd3) + enddo + FracVoidRem = 1.0 - exp(-1.0 * SoilInfilMaxCoeff * TimeStepDay) + SoilWatHoldMaxRem = SoilWatHoldMaxAcc * FracVoidRem + WaterInSfc = max(0.0, SoilSfcInflowMean * TimeStep) + InfilRateMax = (WaterInSfc * (SoilWatHoldMaxRem/(WaterInSfc + SoilWatHoldMaxRem))) / TimeStep + + ! impermeable fraction due to frozen soil + SoilImpervFrac = 1.0 + if ( SoilIceWatTmp > 1.0e-2 ) then + SoilIceCoeff = FrzSoilFac * SoilImpervFracCoeff / SoilIceWatTmp + IndAcc = 1.0 + IndSoilFrz = FrzSoilFac - 1 + do LoopInd1 = 1, IndSoilFrz + LoopInd3 = 1 + do LoopInd2 = LoopInd1+1, IndSoilFrz + LoopInd3 = LoopInd3 * LoopInd2 + enddo + IndAcc = IndAcc + (SoilIceCoeff ** (FrzSoilFac-LoopInd1)) / float(LoopInd3) + enddo + SoilImpervFrac = 1.0 - exp(-SoilIceCoeff) * IndAcc + endif + + ! correction of infiltration limitation + InfilRateMax = InfilRateMax * SoilImpervFrac + ! jref for urban areas + ! if ( FlagUrban .eqv. .true. ) InfilRateMax == InfilRateMax * 0.05 + + ! soil hydraulic conductivity and diffusivity + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, SoilLiqWater(1), SoilIceMax, 1) + + InfilRateMax = max(InfilRateMax, SoilWatConductivity) + InfilRateMax = min(InfilRateMax, WaterInSfc/TimeStep) + + ! compute surface runoff and infiltration rate + RunoffSurface = max(0.0, SoilSfcInflowMean-InfilRateMax) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + endif ! SoilSfcInflowMean > 0.0 + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilWatMaxHold) + + end associate + + end subroutine RunoffSurfaceFreeDrain + +end module RunoffSurfaceFreeDrainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelEquiMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelEquiMod.F90 new file mode 100644 index 0000000000..3e314225d9 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelEquiMod.F90 @@ -0,0 +1,54 @@ +module RunoffSurfaceTopModelEquiMod + +!!! Calculate surface runoff based on TOPMODEL with equilibrium water table (Niu et al., 2005) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceTopModelEqui(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [1/m] + SoilSfcSatFracMax => noahmp%water%param%SoilSfcSatFracMax ,& ! in, maximum surface saturated fraction (global mean) + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! set up key parameter + RunoffDecayFac = 2.0 + + ! compute saturated area fraction + SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * WaterTableDepth) + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceTopModelEqui + +end module RunoffSurfaceTopModelEquiMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelGrdMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelGrdMod.F90 new file mode 100644 index 0000000000..b7d65aa0d6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelGrdMod.F90 @@ -0,0 +1,57 @@ +module RunoffSurfaceTopModelGrdMod + +!!! Calculate surface runoff based on TOPMODEL with groundwater scheme (Niu et al., 2007) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceTopModelGrd(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [1/m] + SoilSfcSatFracMax => noahmp%water%param%SoilSfcSatFracMax ,& ! in, maximum surface saturated fraction (global mean) + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! set up key parameter + !RunoffDecayFac = 6.0 + RunoffDecayFac = SoilExpCoeffB(1) / 3.0 ! calibratable, GY Niu's update 2022 + + ! compute saturated area fraction + !SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * (WaterTableDepth-2.0)) + SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * WaterTableDepth) ! GY Niu's update 2022 + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceTopModelGrd + +end module RunoffSurfaceTopModelGrdMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelMmfMod.F90 new file mode 100644 index 0000000000..7bdb97b8d5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceTopModelMmfMod.F90 @@ -0,0 +1,54 @@ +module RunoffSurfaceTopModelMmfMod + +!!! Calculate surface runoff based on TOPMODEL with MMF groundwater scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceTopModelMMF(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Originally embeded in SOILWATER subroutine instead of as a separate subroutine +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + RunoffDecayFac => noahmp%water%param%RunoffDecayFac ,& ! in, runoff decay factor [1/m] + SoilSfcSatFracMax => noahmp%water%param%SoilSfcSatFracMax ,& ! in, maximum surface saturated fraction (global mean) + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, impervious fraction due to frozen soil + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac ,& ! out, fractional saturated area for soil moisture + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! set up key parameter + RunoffDecayFac = 6.0 + + ! compute saturated area fraction + SoilSaturateFrac = SoilSfcSatFracMax * exp(-0.5 * RunoffDecayFac * max(-2.0-WaterTableDepth,0.0)) + + ! compute surface runoff and infiltration m/s + if ( SoilSfcInflowMean > 0.0 ) then + RunoffSurface = SoilSfcInflowMean * ((1.0-SoilImpervFrac(1)) * SoilSaturateFrac + SoilImpervFrac(1)) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + endif + + end associate + + end subroutine RunoffSurfaceTopModelMMF + +end module RunoffSurfaceTopModelMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceVicMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceVicMod.F90 new file mode 100644 index 0000000000..3e29ca1644 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceVicMod.F90 @@ -0,0 +1,100 @@ +module RunoffSurfaceVicMod + +!!! Compute saturated area, surface infiltration, and surface runoff based on VIC runoff scheme +!!! This scheme is adopted from VIC model + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceVIC(noahmp, TimeStep) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: COMPUTE_VIC_SURFRUNOFF +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variabls + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + +! local variable + integer :: LoopInd ! do-loop index + real(kind=kind_noahmp) :: InfilExpFac ! infitration exponential factor + real(kind=kind_noahmp) :: WaterDepthInit ! initial water depth [m] + real(kind=kind_noahmp) :: WaterDepthMax ! Maximum water depth [m] + real(kind=kind_noahmp) :: InfilVarTmp ! temporary infiltration variable + real(kind=kind_noahmp) :: SoilMoistTop ! top layer soil moisture [m] + real(kind=kind_noahmp) :: SoilMoistTopMax ! top layer max soil moisture [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + InfilFacVic => noahmp%water%param%InfilFacVic ,& ! in, VIC model infiltration parameter + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc ,& ! out, infiltration rate at surface [m/s] + SoilSaturateFrac => noahmp%water%state%SoilSaturateFrac & ! out, fractional saturated area for soil moisture + ) +! ---------------------------------------------------------------------- + + ! Initialization + InfilExpFac = 0.0 + SoilSaturateFrac = 0.0 + WaterDepthMax = 0.0 + WaterDepthInit = 0.0 + InfilVarTmp = 0.0 + SoilMoistTop = 0.0 + SoilMoistTopMax = 0.0 + RunoffSurface = 0.0 + InfilRateSfc = 0.0 + + do LoopInd = 1, NumSoilLayer-2 + SoilMoistTop = SoilMoistTop + SoilMoisture(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + SoilMoistTopMax = SoilMoistTopMax + SoilMoistureSat(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + enddo + + ! fractional saturated area from soil moisture + InfilExpFac = InfilFacVic / ( 1.0 + InfilFacVic ) + SoilSaturateFrac = 1.0 - (max(0.0, (1.0-(SoilMoistTop/SoilMoistTopMax))))**InfilExpFac + SoilSaturateFrac = max(0.0, SoilSaturateFrac) + SoilSaturateFrac = min(1.0, SoilSaturateFrac) + + ! Infiltration for the previous time-step soil moisture based on SoilSaturateFrac + WaterDepthMax = (1.0 + InfilFacVic) * SoilMoistTopMax + WaterDepthInit = WaterDepthMax * (1.0 - (1.0 - SoilSaturateFrac)**(1.0/InfilFacVic)) + + ! Solve for surface runoff + if ( SoilSfcInflowMean == 0.0 ) then + RunoffSurface = 0.0 + else if ( WaterDepthMax == 0.0 ) then + RunoffSurface = SoilSfcInflowMean * TimeStep + else if ( (WaterDepthInit + (SoilSfcInflowMean*TimeStep)) > WaterDepthMax ) then + RunoffSurface = SoilSfcInflowMean * TimeStep - SoilMoistTopMax + SoilMoistTop + else + InfilVarTmp = 1.0 - ((WaterDepthInit + (SoilSfcInflowMean * TimeStep) ) / WaterDepthMax) + RunoffSurface = SoilSfcInflowMean * TimeStep - SoilMoistTopMax + SoilMoistTop + & + SoilMoistTopMax * (InfilVarTmp**(1.0+InfilFacVic)) + endif + + RunoffSurface = RunoffSurface / TimeStep + if ( RunoffSurface < 0.0 ) RunoffSurface = 0.0 + if ( RunoffSurface > SoilSfcInflowMean) RunoffSurface = SoilSfcInflowMean + + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + end associate + + end subroutine RunoffSurfaceVIC + +end module RunoffSurfaceVicMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceXinAnJiangMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceXinAnJiangMod.F90 new file mode 100644 index 0000000000..b067be4fe4 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/RunoffSurfaceXinAnJiangMod.F90 @@ -0,0 +1,110 @@ +module RunoffSurfaceXinAnJiangMod + +!!! Compute surface infiltration rate and surface runoff based on XinAnJiang runoff scheme +!!! Reference: Knoben, W. J., et al., (2019): Modular Assessment of Rainfall-Runoff Models +!!! Toolbox (MARRMoT) v1.2 an open-source, extendable framework providing implementations +!!! of 46 conceptual hydrologic models as continuous state-space formulations. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine RunoffSurfaceXinAnJiang(noahmp, TimeStep) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: COMPUTE_XAJ_SURFRUNOFF +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN & OUT variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + +! local variable + integer :: LoopInd ! do-loop index + real(kind=kind_noahmp) :: SoilWaterTmp ! temporary soil water [m] + real(kind=kind_noahmp) :: SoilWaterMax ! maximum soil water [m] + real(kind=kind_noahmp) :: SoilWaterFree ! free soil water [m] + real(kind=kind_noahmp) :: SoilWaterFreeMax ! maximum free soil water [m] + real(kind=kind_noahmp) :: RunoffSfcImp ! impervious surface runoff [m] + real(kind=kind_noahmp) :: RunoffSfcPerv ! pervious surface runoff [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, fraction of imperviousness due to frozen soil + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + TensionWatDistrInfl => noahmp%water%param%TensionWatDistrInfl ,& ! in, Tension water distribution inflection parameter + TensionWatDistrShp => noahmp%water%param%TensionWatDistrShp ,& ! in, Tension water distribution shape parameter + FreeWatDistrShp => noahmp%water%param%FreeWatDistrShp ,& ! in, Free water distribution shape parameter + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [m/s] + InfilRateSfc => noahmp%water%flux%InfilRateSfc & ! out, infiltration rate at surface [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + SoilWaterTmp = 0.0 + SoilWaterMax = 0.0 + SoilWaterFree = 0.0 + SoilWaterFreeMax = 0.0 + RunoffSfcImp = 0.0 + RunoffSfcPerv = 0.0 + RunoffSurface = 0.0 + InfilRateSfc = 0.0 + + do LoopInd = 1, NumSoilLayer-2 + if ( (SoilMoisture(LoopInd)-SoilMoistureFieldCap(LoopInd)) > 0.0 ) then ! soil moisture greater than field capacity + SoilWaterFree = SoilWaterFree + & + (SoilMoisture(LoopInd)-SoilMoistureFieldCap(LoopInd)) * (-1.0) * DepthSoilLayer(LoopInd) + SoilWaterTmp = SoilWaterTmp + SoilMoistureFieldCap(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + else + SoilWaterTmp = SoilWaterTmp + SoilMoisture(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + endif + SoilWaterMax = SoilWaterMax + SoilMoistureFieldCap(LoopInd) * (-1.0) * DepthSoilLayer(LoopInd) + SoilWaterFreeMax = SoilWaterFreeMax + & + (SoilMoistureSat(LoopInd)-SoilMoistureFieldCap(LoopInd)) * (-1.0) * DepthSoilLayer(LoopInd) + enddo + SoilWaterTmp = min(SoilWaterTmp, SoilWaterMax) ! tension water [m] + SoilWaterFree = min(SoilWaterFree, SoilWaterFreeMax) ! free water [m] + + ! impervious surface runoff R_IMP + RunoffSfcImp = SoilImpervFrac(1) * SoilSfcInflowMean * TimeStep + + ! solve pervious surface runoff (m) based on Eq. (310) + if ( (SoilWaterTmp/SoilWaterMax) <= (0.5-TensionWatDistrInfl) ) then + RunoffSfcPerv = (1.0-SoilImpervFrac(1)) * SoilSfcInflowMean * TimeStep * & + ((0.5-TensionWatDistrInfl)**(1.0-TensionWatDistrShp)) * & + ((SoilWaterTmp/SoilWaterMax)**TensionWatDistrShp) + else + RunoffSfcPerv = (1.0-SoilImpervFrac(1)) * SoilSfcInflowMean * TimeStep * & + (1.0-(((0.5+TensionWatDistrInfl)**(1.0-TensionWatDistrShp)) * & + ((1.0-(SoilWaterTmp/SoilWaterMax))**TensionWatDistrShp))) + endif + + ! estimate surface runoff based on Eq. (313) + if ( SoilSfcInflowMean == 0.0 ) then + RunoffSurface = 0.0 + else + RunoffSurface = RunoffSfcPerv * (1.0-((1.0-(SoilWaterFree/SoilWaterFreeMax))**FreeWatDistrShp)) + RunoffSfcImp + endif + RunoffSurface = RunoffSurface / TimeStep + RunoffSurface = max(0.0,RunoffSurface) + RunoffSurface = min(SoilSfcInflowMean, RunoffSurface) + InfilRateSfc = SoilSfcInflowMean - RunoffSurface + + end associate + + end subroutine RunoffSurfaceXinAnJiang + +end module RunoffSurfaceXinAnJiangMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/ShallowWaterTableMmfMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/ShallowWaterTableMmfMod.F90 new file mode 100644 index 0000000000..32c1b70aaf --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/ShallowWaterTableMmfMod.F90 @@ -0,0 +1,176 @@ +module ShallowWaterTableMmfMod + +!!! Diagnoses water table depth and computes recharge when the water table is +!!! within the resolved soil layers, according to the Miguez-Macho&Fan scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine ShallowWaterTableMMF(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SHALLOWWATERTABLE +! Original code: Miguez-Macho&Fan (Miguez-Macho et al 2007, Fan et al 2007) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do-loop index + integer :: IndAbvWatTbl ! layer index above water table layer + integer :: IndWatTbl ! layer index where the water table layer is + real(kind=kind_noahmp) :: WatTblDepthOld ! old water table depth + real(kind=kind_noahmp) :: ThicknessUpLy ! upper layer thickness + real(kind=kind_noahmp) :: SoilMoistDeep ! deep layer soil moisture + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSoilLayer0 ! temporary soil depth + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth of soil layer-bottom [m] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilMoistureEqui => noahmp%water%state%SoilMoistureEqui ,& ! in, equilibrium soil water content [m3/m3] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil water content [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! inout, water table depth [m] + SoilMoistureToWT => noahmp%water%state%SoilMoistureToWT ,& ! inout, soil moisture between bottom of soil & water table + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! inout, soil bottom drainage [m/s] + RechargeGwShallowWT => noahmp%water%state%RechargeGwShallowWT & ! out, groundwater recharge (net vertical flux across water table), positive up + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSoilLayer0)) allocate(DepthSoilLayer0(0:NumSoilLayer)) + DepthSoilLayer0(1:NumSoilLayer) = DepthSoilLayer(1:NumSoilLayer) + DepthSoilLayer0(0) = 0.0 + + ! find the layer where the water table is + do LoopInd = NumSoilLayer, 1, -1 + if ( (WaterTableDepth+1.0e-6) < DepthSoilLayer0(LoopInd) ) exit + enddo + IndAbvWatTbl = LoopInd + + IndWatTbl = IndAbvWatTbl + 1 ! layer where the water table is + if ( IndWatTbl <= NumSoilLayer ) then ! water table depth in the resolved layers + WatTblDepthOld = WaterTableDepth + if ( SoilMoisture(IndWatTbl) > SoilMoistureEqui(IndWatTbl) ) then + if ( SoilMoisture(IndWatTbl) == SoilMoistureSat(IndWatTbl) ) then ! wtd went to the layer above + WaterTableDepth = DepthSoilLayer0(IndAbvWatTbl) + RechargeGwShallowWT = -(WatTblDepthOld - WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + IndAbvWatTbl = IndAbvWatTbl-1 + IndWatTbl = IndWatTbl-1 + if ( IndWatTbl >= 1 ) then + if ( SoilMoisture(IndWatTbl) > SoilMoistureEqui(IndWatTbl) ) then + WatTblDepthOld = WaterTableDepth + WaterTableDepth = min((SoilMoisture(IndWatTbl)*ThicknessSnowSoilLayer(IndWatTbl) - & + SoilMoistureEqui(IndWatTbl)*DepthSoilLayer0(IndAbvWatTbl) + & + SoilMoistureSat(IndWatTbl)*DepthSoilLayer0(IndWatTbl)) / & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)), & + DepthSoilLayer0(IndAbvWatTbl) ) + RechargeGwShallowWT = RechargeGwShallowWT - (WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)) + endif + endif + else ! water table depth stays in the layer + WaterTableDepth = min((SoilMoisture(IndWatTbl)*ThicknessSnowSoilLayer(IndWatTbl) - & + SoilMoistureEqui(IndWatTbl)*DepthSoilLayer0(IndAbvWatTbl) + & + SoilMoistureSat(IndWatTbl)*DepthSoilLayer0(IndWatTbl) ) / & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)), & + DepthSoilLayer0(IndAbvWatTbl)) + RechargeGwShallowWT = -(WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + endif + else ! water table depth has gone down to the layer below + WaterTableDepth = DepthSoilLayer0(IndWatTbl) + RechargeGwShallowWT = -(WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + IndWatTbl = IndWatTbl + 1 + IndAbvWatTbl = IndAbvWatTbl + 1 + ! water table depth crossed to the layer below. Now adjust it there + if ( IndWatTbl <= NumSoilLayer ) then + WatTblDepthOld = WaterTableDepth + if ( SoilMoisture(IndWatTbl) > SoilMoistureEqui(IndWatTbl) ) then + WaterTableDepth = min((SoilMoisture(IndWatTbl)*ThicknessSnowSoilLayer(IndWatTbl) - & + SoilMoistureEqui(IndWatTbl)*DepthSoilLayer0(IndAbvWatTbl) + & + SoilMoistureSat(IndWatTbl)*DepthSoilLayer0(IndWatTbl) ) / & + (SoilMoistureSat(IndWatTbl)-SoilMoistureEqui(IndWatTbl)), & + DepthSoilLayer0(IndAbvWatTbl)) + else + WaterTableDepth = DepthSoilLayer0(IndWatTbl) + endif + RechargeGwShallowWT = RechargeGwShallowWT - (WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(IndWatTbl) - SoilMoistureEqui(IndWatTbl)) + else + WatTblDepthOld = WaterTableDepth + ! restore smoi to equilibrium value with water from the ficticious layer below + ! SoilMoistureToWT = SoilMoistureToWT - (SoilMoistureEqui(NumSoilLayer)-SoilMoisture(NumSoilLayer)) + ! DrainSoilBot = DrainSoilBot - 1000 * & + ! (SoilMoistureEqui(NumSoilLayer) - SoilMoisture(NumSoilLayer)) * & + ! ThicknessSnowSoilLayer(NumSoilLayer) / SoilTimeStep + ! SoilMoisture(NumSoilLayer) = SoilMoistureEqui(NumSoilLayer) + + ! adjust water table depth in the ficticious layer below + SoilMoistDeep = SoilMoistureSat(NumSoilLayer) * (-SoilMatPotentialSat(NumSoilLayer) / & + (-SoilMatPotentialSat(NumSoilLayer) - ThicknessSnowSoilLayer(NumSoilLayer)))** & + (1.0/SoilExpCoeffB(NumSoilLayer)) + WaterTableDepth = min((SoilMoistureToWT * ThicknessSnowSoilLayer(NumSoilLayer) - & + SoilMoistDeep * DepthSoilLayer0(NumSoilLayer) + & + SoilMoistureSat(NumSoilLayer) * (DepthSoilLayer0(NumSoilLayer) - & + ThicknessSnowSoilLayer(NumSoilLayer))) / & + (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep), DepthSoilLayer0(NumSoilLayer)) + RechargeGwShallowWT = RechargeGwShallowWT - (WatTblDepthOld-WaterTableDepth) * & + (SoilMoistureSat(NumSoilLayer) - SoilMoistDeep) + endif + endif + else if ( WaterTableDepth >= (DepthSoilLayer0(NumSoilLayer)-ThicknessSnowSoilLayer(NumSoilLayer)) ) then + ! if water table depth was already below the bottom of the resolved soil crust + WatTblDepthOld = WaterTableDepth + SoilMoistDeep = SoilMoistureSat(NumSoilLayer) * (-SoilMatPotentialSat(NumSoilLayer) / & + (-SoilMatPotentialSat(NumSoilLayer) - ThicknessSnowSoilLayer(NumSoilLayer)))** & + (1.0/SoilExpCoeffB(NumSoilLayer)) + if ( SoilMoistureToWT > SoilMoistDeep ) then + WaterTableDepth = min((SoilMoistureToWT * ThicknessSnowSoilLayer(NumSoilLayer) - & + SoilMoistDeep * DepthSoilLayer0(NumSoilLayer) + & + SoilMoistureSat(NumSoilLayer) * (DepthSoilLayer0(NumSoilLayer) - & + ThicknessSnowSoilLayer(NumSoilLayer))) / & + (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep), DepthSoilLayer0(NumSoilLayer)) + RechargeGwShallowWT = -(WatTblDepthOld-WaterTableDepth) * (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep) + else + RechargeGwShallowWT = -(WatTblDepthOld - (DepthSoilLayer0(NumSoilLayer)-ThicknessSnowSoilLayer(NumSoilLayer))) * & + (SoilMoistureSat(NumSoilLayer) - SoilMoistDeep) + WatTblDepthOld = DepthSoilLayer0(NumSoilLayer) - ThicknessSnowSoilLayer(NumSoilLayer) + ! and now even further down + ThicknessUpLy = (SoilMoistDeep - SoilMoistureToWT) * ThicknessSnowSoilLayer(NumSoilLayer) / & + (SoilMoistureSat(NumSoilLayer) - SoilMoistDeep) + WaterTableDepth = WatTblDepthOld - ThicknessUpLy + RechargeGwShallowWT = RechargeGwShallowWT - (SoilMoistureSat(NumSoilLayer)-SoilMoistDeep) * ThicknessUpLy + SoilMoistureToWT = SoilMoistDeep + endif + endif + + if ( (IndAbvWatTbl < NumSoilLayer) .and. (IndAbvWatTbl > 0) ) then + SoilMoistureToWT = SoilMoistureSat(IndAbvWatTbl) + else if ( (IndAbvWatTbl < NumSoilLayer) .and. (IndAbvWatTbl <= 0) ) then + SoilMoistureToWT = SoilMoistureSat(1) + endif + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSoilLayer0) + + end associate + + end subroutine ShallowWaterTableMMF + +end module ShallowWaterTableMmfMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowAgingBatsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowAgingBatsMod.F90 new file mode 100644 index 0000000000..c883c1ef6c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowAgingBatsMod.F90 @@ -0,0 +1,74 @@ +module SnowAgingBatsMod + +!!! Estimate snow age based on BATS snow albedo scheme for use in BATS snow albedo calculation +!!! Reference: Yang et al. (1997) J.of Climate + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowAgingBats(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOW_AGE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: SnowAgeFacTot ! total aging effects + real(kind=kind_noahmp) :: SnowAgeVapEff ! effects of grain growth due to vapor diffusion + real(kind=kind_noahmp) :: SnowAgeFrzEff ! effects of grain growth at freezing of melt water + real(kind=kind_noahmp) :: SnowAgeSootEff ! effects of soot + real(kind=kind_noahmp) :: SnowAgeChg ! nondimensional snow age change + real(kind=kind_noahmp) :: SnowAgeTmp ! temporary nondimensional snow age + real(kind=kind_noahmp) :: SnowFreshFac ! fresh snowfall factor + real(kind=kind_noahmp) :: SnowAgeTimeFac ! snow aging time factor + real(kind=kind_noahmp) :: SnowGrowVapExp ! snow vapor diffusion growth exponential factor + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + SnowMassFullCoverOld => noahmp%water%param%SnowMassFullCoverOld ,& ! in, new snow mass to fully cover old snow [mm] + SnowAgeFacBats => noahmp%energy%param%SnowAgeFacBats ,& ! in, snow aging parameter + SnowGrowVapFacBats => noahmp%energy%param%SnowGrowVapFacBats ,& ! in, vapor diffusion snow growth factor + SnowGrowFrzFacBats => noahmp%energy%param%SnowGrowFrzFacBats ,& ! in, extra snow growth factor near freezing + SnowSootFacBats => noahmp%energy%param%SnowSootFacBats ,& ! in, dirt and soot effect factor + TemperatureGrd => noahmp%energy%state%TemperatureGrd ,& ! in, ground temperature [K] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SnowWaterEquivPrev => noahmp%water%state%SnowWaterEquivPrev ,& ! in, snow water equivalent at previous time step [mm] + SnowAgeNondim => noahmp%energy%state%SnowAgeNondim ,& ! inout, non-dimensional snow age + SnowAgeFac => noahmp%energy%state%SnowAgeFac & ! out, snow age factor + ) +! ---------------------------------------------------------------------- + + if ( SnowWaterEquiv <= 0.0 ) then + SnowAgeNondim = 0.0 + else + SnowAgeTimeFac = MainTimeStep / SnowAgeFacBats + SnowGrowVapExp = SnowGrowVapFacBats * (1.0/ConstFreezePoint - 1.0/TemperatureGrd) + SnowAgeVapEff = exp(SnowGrowVapExp) + SnowAgeFrzEff = exp(amin1(0.0, SnowGrowFrzFacBats*SnowGrowVapExp)) + SnowAgeSootEff = SnowSootFacBats + SnowAgeFacTot = SnowAgeVapEff + SnowAgeFrzEff + SnowAgeSootEff + SnowAgeChg = SnowAgeTimeFac * SnowAgeFacTot + SnowFreshFac = amax1(0.0, SnowWaterEquiv-SnowWaterEquivPrev) / SnowMassFullCoverOld + SnowAgeTmp = (SnowAgeNondim + SnowAgeChg) * (1.0 - SnowFreshFac) + SnowAgeNondim = amax1(0.0, SnowAgeTmp) + endif + + SnowAgeFac = SnowAgeNondim / (SnowAgeNondim + 1.0) + + end associate + + end subroutine SnowAgingBats + +end module SnowAgingBatsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoBatsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoBatsMod.F90 new file mode 100644 index 0000000000..9ab51bc5b7 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoBatsMod.F90 @@ -0,0 +1,68 @@ +module SnowAlbedoBatsMod + +!!! Compute snow albedo based on BATS scheme (Yang et al. (1997) J.of Climate) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowAlbedoBats(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWALB_BATS +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: ZenithAngFac ! solar zenith angle correction factor + real(kind=kind_noahmp) :: ZenithAngFacTmp ! temperary zenith angle correction factor + real(kind=kind_noahmp) :: SolarAngleFac2 ! 2.0 * SolarAngleFac + real(kind=kind_noahmp) :: SolarAngleFac1 ! 1 / SolarAngleFac + real(kind=kind_noahmp) :: SolarAngleFac ! adjustable solar zenith angle factor + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + SolarZenithAdjBats => noahmp%energy%param%SolarZenithAdjBats ,& ! in, zenith angle snow albedo adjustment + FreshSnoAlbVisBats => noahmp%energy%param%FreshSnoAlbVisBats ,& ! in, new snow visible albedo + FreshSnoAlbNirBats => noahmp%energy%param%FreshSnoAlbNirBats ,& ! in, new snow NIR albedo + SnoAgeFacDifVisBats => noahmp%energy%param%SnoAgeFacDifVisBats ,& ! in, age factor for diffuse visible snow albedo + SnoAgeFacDifNirBats => noahmp%energy%param%SnoAgeFacDifNirBats ,& ! in, age factor for diffuse NIR snow albedo + SzaFacDirVisBats => noahmp%energy%param%SzaFacDirVisBats ,& ! in, cosz factor for direct visible snow albedo + SzaFacDirNirBats => noahmp%energy%param%SzaFacDirNirBats ,& ! in, cosz factor for direct NIR snow albedo + SnowAgeFac => noahmp%energy%state%SnowAgeFac ,& ! in, snow age factor + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif & ! out, snow albedo for diffuse(1=vis, 2=nir) + ) +! ---------------------------------------------------------------------- + + ! initialization + AlbedoSnowDir(1:NumSwRadBand) = 0.0 + AlbedoSnowDif(1:NumSwRadBand) = 0.0 + + ! when CosSolarZenithAngle > 0 + SolarAngleFac = SolarZenithAdjBats + SolarAngleFac1 = 1.0 / SolarAngleFac + SolarAngleFac2 = 2.0 * SolarAngleFac + ZenithAngFacTmp = (1.0 + SolarAngleFac1) / (1.0 + SolarAngleFac2*CosSolarZenithAngle) - SolarAngleFac1 + ZenithAngFac = amax1(ZenithAngFacTmp, 0.0) + AlbedoSnowDif(1) = FreshSnoAlbVisBats * (1.0 - SnoAgeFacDifVisBats * SnowAgeFac) + AlbedoSnowDif(2) = FreshSnoAlbNirBats * (1.0 - SnoAgeFacDifNirBats * SnowAgeFac) + AlbedoSnowDir(1) = AlbedoSnowDif(1) + SzaFacDirVisBats * ZenithAngFac * (1.0 - AlbedoSnowDif(1)) + AlbedoSnowDir(2) = AlbedoSnowDif(2) + SzaFacDirNirBats * ZenithAngFac * (1.0 - AlbedoSnowDif(2)) + + end associate + + end subroutine SnowAlbedoBats + +end module SnowAlbedoBatsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoClassMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoClassMod.F90 new file mode 100644 index 0000000000..06185e9d6d --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowAlbedoClassMod.F90 @@ -0,0 +1,68 @@ +module SnowAlbedoClassMod + +!!! Compute snow albedo based on the CLASS scheme (Verseghy, 1991) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowAlbedoClass(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWALB_CLASS +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: SnowAlbedoTmp ! temporary snow albedo + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! in, snowfall at ground [mm/s] + SnowMassFullCoverOld => noahmp%water%param%SnowMassFullCoverOld ,& ! in, new snow mass to fully cover old snow [mm] + SnowAlbRefClass => noahmp%energy%param%SnowAlbRefClass ,& ! in, reference snow albedo in CLASS scheme + SnowAgeFacClass => noahmp%energy%param%SnowAgeFacClass ,& ! in, snow aging e-folding time [s] + SnowAlbFreshClass => noahmp%energy%param%SnowAlbFreshClass ,& ! in, fresh snow albedo + AlbedoSnowPrev => noahmp%energy%state%AlbedoSnowPrev ,& ! in, snow albedo at last time step + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct (1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif & ! out, snow albedo for diffuse (1=vis, 2=nir) + ) +! ---------------------------------------------------------------------- + + ! initialization + AlbedoSnowDir(1:NumSwRadBand) = 0.0 + AlbedoSnowDif(1:NumSwRadBand) = 0.0 + + ! when CosSolarZenithAngle > 0 + SnowAlbedoTmp = SnowAlbRefClass + (AlbedoSnowPrev-SnowAlbRefClass) * exp(-0.01*MainTimeStep/SnowAgeFacClass) + + ! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 + ! here assume 1cm snow depth will fully cover the old snow + if ( SnowfallGround > 0.0 ) then + SnowAlbedoTmp = SnowAlbedoTmp + min(SnowfallGround, SnowMassFullCoverOld/MainTimeStep) * & + (SnowAlbFreshClass-SnowAlbedoTmp) / (SnowMassFullCoverOld/MainTimeStep) + endif + + AlbedoSnowDif(1) = SnowAlbedoTmp + AlbedoSnowDif(2) = SnowAlbedoTmp + AlbedoSnowDir(1) = SnowAlbedoTmp + AlbedoSnowDir(2) = SnowAlbedoTmp + + AlbedoSnowPrev = SnowAlbedoTmp + + end associate + + end subroutine SnowAlbedoClass + +end module SnowAlbedoClassMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGlacierMod.F90 new file mode 100644 index 0000000000..9d0b58f123 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGlacierMod.F90 @@ -0,0 +1,41 @@ +module SnowCoverGlacierMod + +!!! Compute glacier ground snow cover fraction + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowCoverGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in RADIATION_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + +! -------------------------------------------------------------------- + associate( & + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac & ! out, snow cover fraction + ) +! ---------------------------------------------------------------------- + + SnowCoverFrac = 0.0 + if ( SnowWaterEquiv > 0.0 ) SnowCoverFrac = 1.0 + + end associate + + end subroutine SnowCoverGlacier + +end module SnowCoverGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGroundNiu07Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGroundNiu07Mod.F90 new file mode 100644 index 0000000000..78456dee97 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowCoverGroundNiu07Mod.F90 @@ -0,0 +1,51 @@ +module SnowCoverGroundNiu07Mod + +!!! Compute ground snow cover fraction based on Niu and Yang (2007, JGR) scheme + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowCoverGroundNiu07(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp) :: SnowDensBulk ! bulk density of snow [Kg/m3] + real(kind=kind_noahmp) :: MeltFac ! melting factor for snow cover frac + +! -------------------------------------------------------------------- + associate( & + SnowMeltFac => noahmp%water%param%SnowMeltFac ,& ! in, snowmelt m parameter + SnowCoverFac => noahmp%water%param%SnowCoverFac ,& ! in, snow cover factor [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! in, snow water equivalent [mm] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac & ! out, snow cover fraction + ) +! ---------------------------------------------------------------------- + + SnowCoverFrac = 0.0 + if ( SnowDepth > 0.0 ) then + SnowDensBulk = SnowWaterEquiv / SnowDepth + MeltFac = (SnowDensBulk / 100.0)**SnowMeltFac + !SnowCoverFrac = tanh( SnowDepth /(2.5 * Z0 * MeltFac)) + SnowCoverFrac = tanh( SnowDepth /(SnowCoverFac * MeltFac)) ! C.He: bring hard-coded 2.5*z0 to MPTABLE + endif + + end associate + + end subroutine SnowCoverGroundNiu07 + +end module SnowCoverGroundNiu07Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerCombineMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerCombineMod.F90 new file mode 100644 index 0000000000..909542f2b5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerCombineMod.F90 @@ -0,0 +1,185 @@ +module SnowLayerCombineMod + +!!! Snowpack layer combination process +!!! Update snow ice, snow water, snow thickness, snow temperature + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerWaterComboMod, only: SnowLayerWaterCombo + + implicit none + +contains + + subroutine SnowLayerCombine(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: COMBINE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: I,J,K,L ! node indices + integer :: NumSnowLayerOld ! number of snow layer + integer :: IndLayer ! node index + integer :: IndNeighbor ! adjacent node selected for combination + real(kind=kind_noahmp) :: SnowIceTmp ! total ice mass in snow + real(kind=kind_noahmp) :: SnowLiqTmp ! total liquid water in snow + real(kind=kind_noahmp) :: SnowThickMin(3) ! minimum thickness of each snow layer + data SnowThickMin /0.025, 0.025, 0.1/ ! MB: change limit + !data SnowThickMin /0.045, 0.05, 0.2/ + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil liquid moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + +! check and combine small ice content layer + NumSnowLayerOld = NumSnowLayerNeg + + do J = NumSnowLayerOld+1,0 + if ( SnowIce(J) <= 0.1 ) then + if ( J /= 0 ) then + SnowLiqWater(J+1) = SnowLiqWater(J+1) + SnowLiqWater(J) + SnowIce(J+1) = SnowIce(J+1) + SnowIce(J) + ThicknessSnowSoilLayer(J+1) = ThicknessSnowSoilLayer(J+1) + ThicknessSnowSoilLayer(J) + else + if ( NumSnowLayerNeg < -1 ) then ! MB/KM: change to NumSnowLayerNeg + SnowLiqWater(J-1) = SnowLiqWater(J-1) + SnowLiqWater(J) + SnowIce(J-1) = SnowIce(J-1) + SnowIce(J) + ThicknessSnowSoilLayer(J-1) = ThicknessSnowSoilLayer(J-1) + ThicknessSnowSoilLayer(J) + else + if ( SnowIce(J) >= 0.0 ) then + PondSfcThinSnwComb = SnowLiqWater(J) ! NumSnowLayerNeg WILL GET SET TO ZERO BELOW; PondSfcThinSnwComb WILL GET + SnowWaterEquiv = SnowIce(J) ! ADDED TO PONDING FROM PHASECHANGE PONDING SHOULD BE + SnowDepth = ThicknessSnowSoilLayer(J) ! ZERO HERE BECAUSE IT WAS CALCULATED FOR THIN SNOW + else ! SnowIce OVER-SUBLIMATED EARLIER + PondSfcThinSnwComb = SnowLiqWater(J) + SnowIce(J) + if ( PondSfcThinSnwComb < 0.0 ) then ! IF SnowIce AND SnowLiqWater SUBLIMATES REMOVE FROM SOIL + SoilIce(1) = SoilIce(1) + PondSfcThinSnwComb/(ThicknessSnowSoilLayer(1)*1000.0) ! negative SoilIce from oversublimation is adjusted below + PondSfcThinSnwComb = 0.0 + endif + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + endif ! if(SnowIce(J) >= 0.0) + SnowLiqWater(J) = 0.0 + SnowIce(J) = 0.0 + ThicknessSnowSoilLayer(J) = 0.0 + endif ! if(NumSnowLayerOld < -1) + + !SoilLiqWater(1) = SoilLiqWater(1) + SnowLiqWater(J)/(ThicknessSnowSoilLayer(1)*1000.0) + !SoilIce(1) = SoilIce(1) + SnowIce(J)/(ThicknessSnowSoilLayer(1)*1000.0) + endif ! if(J /= 0) + + ! shift all elements above this down by one. + if ( (J > NumSnowLayerNeg+1) .and. (NumSnowLayerNeg < -1) ) then + do I = J, NumSnowLayerNeg+2, -1 + TemperatureSoilSnow(I) = TemperatureSoilSnow(I-1) + SnowLiqWater(I) = SnowLiqWater(I-1) + SnowIce(I) = SnowIce(I-1) + ThicknessSnowSoilLayer(I) = ThicknessSnowSoilLayer(I-1) + enddo + endif + NumSnowLayerNeg = NumSnowLayerNeg + 1 + + endif ! if(SnowIce(J) <= 0.1) + enddo ! do J + +! to conserve water in case of too large surface sublimation + if ( SoilIce(1) < 0.0) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + + if ( NumSnowLayerNeg ==0 ) return ! MB: get out if no longer multi-layer + + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + SnowIceTmp = 0.0 + SnowLiqTmp = 0.0 + + do J = NumSnowLayerNeg+1, 0 + SnowWaterEquiv = SnowWaterEquiv + SnowIce(J) + SnowLiqWater(J) + SnowDepth = SnowDepth + ThicknessSnowSoilLayer(J) + SnowIceTmp = SnowIceTmp + SnowIce(J) + SnowLiqTmp = SnowLiqTmp + SnowLiqWater(J) + enddo + +! check the snow depth - all snow gone, the liquid water assumes ponding on soil surface. + !if ( (SnowDepth < 0.05) .and. (NumSnowLayerNeg < 0) ) then + if ( (SnowDepth < 0.025) .and. (NumSnowLayerNeg < 0) ) then ! MB: change limit + NumSnowLayerNeg = 0 + SnowWaterEquiv = SnowIceTmp + PondSfcThinSnwTrans = SnowLiqTmp ! LIMIT OF NumSnowLayerNeg < 0 MEANS INPUT PONDING + if ( SnowWaterEquiv <= 0.0 ) SnowDepth = 0.0 ! SHOULD BE ZERO; SEE ABOVE + endif + +! check the snow depth - snow layers combined + if ( NumSnowLayerNeg < -1 ) then + NumSnowLayerOld = NumSnowLayerNeg + IndLayer = 1 + do I = NumSnowLayerOld+1, 0 + if ( ThicknessSnowSoilLayer(I) < SnowThickMin(IndLayer) ) then + if ( I == NumSnowLayerNeg+1 ) then + IndNeighbor = I + 1 + else if ( I == 0 ) then + IndNeighbor = I - 1 + else + IndNeighbor = I + 1 + if ( (ThicknessSnowSoilLayer(I-1)+ThicknessSnowSoilLayer(I)) < & + (ThicknessSnowSoilLayer(I+1)+ThicknessSnowSoilLayer(I)) ) IndNeighbor = I-1 + endif + ! Node l and j are combined and stored as node j. + if ( IndNeighbor > I ) then + J = IndNeighbor + L = I + else + J = I + L = IndNeighbor + endif + + ! update combined snow water & temperature + call SnowLayerWaterCombo(ThicknessSnowSoilLayer(J), SnowLiqWater(J), SnowIce(J), TemperatureSoilSnow(J), & + ThicknessSnowSoilLayer(L), SnowLiqWater(L), SnowIce(L), TemperatureSoilSnow(L) ) + + ! Now shift all elements above this down one. + if ( (J-1) > (NumSnowLayerNeg+1) ) then + do K = J-1, NumSnowLayerNeg+2, -1 + TemperatureSoilSnow(K) = TemperatureSoilSnow(K-1) + SnowIce(K) = SnowIce(K-1) + SnowLiqWater(K) = SnowLiqWater(K-1) + ThicknessSnowSoilLayer(K) = ThicknessSnowSoilLayer(K-1) + enddo + endif + ! Decrease the number of snow layers + NumSnowLayerNeg = NumSnowLayerNeg + 1 + if ( NumSnowLayerNeg >= -1 ) Exit + else + ! The layer thickness is greater than the prescribed minimum value + IndLayer = IndLayer + 1 + endif + enddo + endif + + end associate + + end subroutine SnowLayerCombine + +end module SnowLayerCombineMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerDivideMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerDivideMod.F90 new file mode 100644 index 0000000000..6254978a41 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerDivideMod.F90 @@ -0,0 +1,160 @@ +module SnowLayerDivideMod + +!!! Snowpack layer division process +!!! Update snow ice, snow water, snow thickness, snow temperature + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerWaterComboMod, only: SnowLayerWaterCombo + + implicit none + +contains + + subroutine SnowLayerDivide(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: DIVIDE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! snow layer loop index + integer :: NumSnowLayerTmp ! number of snow layer top to bottom + real(kind=kind_noahmp) :: SnowThickCombTmp ! thickness of the combined [m] + real(kind=kind_noahmp) :: SnowIceExtra ! extra snow ice to be divided compared to allowed layer thickness + real(kind=kind_noahmp) :: SnowLiqExtra ! extra snow liquid water to be divided compared to allowed layer thickness + real(kind=kind_noahmp) :: SnowFracExtra ! fraction of extra snow to be divided compared to allowed layer thickness + real(kind=kind_noahmp) :: SnowTempGrad ! temperature gradient between two snow layers + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowThickTmp ! snow layer thickness [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceTmp ! partial volume of ice [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqTmp ! partial volume of liquid water [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: TemperatureSnowTmp ! node temperature [K] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater & ! inout, snow layer liquid water [mm] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowIceTmp) ) allocate(SnowIceTmp (1:NumSnowLayerMax)) + if (.not. allocated(SnowLiqTmp) ) allocate(SnowLiqTmp (1:NumSnowLayerMax)) + if (.not. allocated(TemperatureSnowTmp)) allocate(TemperatureSnowTmp(1:NumSnowLayerMax)) + if (.not. allocated(SnowThickTmp) ) allocate(SnowThickTmp (1:NumSnowLayerMax)) + SnowIceTmp (:) = 0.0 + SnowLiqTmp (:) = 0.0 + TemperatureSnowTmp(:) = 0.0 + SnowThickTmp (:) = 0.0 + + do LoopInd = 1, NumSnowLayerMax + if ( LoopInd <= abs(NumSnowLayerNeg) ) then + SnowThickTmp(LoopInd) = ThicknessSnowSoilLayer(LoopInd+NumSnowLayerNeg) + SnowIceTmp(LoopInd) = SnowIce(LoopInd+NumSnowLayerNeg) + SnowLiqTmp(LoopInd) = SnowLiqWater(LoopInd+NumSnowLayerNeg) + TemperatureSnowTmp(LoopInd) = TemperatureSoilSnow(LoopInd+NumSnowLayerNeg) + endif + enddo + + ! start snow layer division + NumSnowLayerTmp = abs(NumSnowLayerNeg) + + if ( NumSnowLayerTmp == 1 ) then + ! Specify a new snow layer + if ( SnowThickTmp(1) > 0.05 ) then + NumSnowLayerTmp = 2 + SnowThickTmp(1) = SnowThickTmp(1)/2.0 + SnowIceTmp(1) = SnowIceTmp(1)/2.0 + SnowLiqTmp(1) = SnowLiqTmp(1)/2.0 + SnowThickTmp(2) = SnowThickTmp(1) + SnowIceTmp(2) = SnowIceTmp(1) + SnowLiqTmp(2) = SnowLiqTmp(1) + TemperatureSnowTmp(2) = TemperatureSnowTmp(1) + endif + endif + + if ( NumSnowLayerTmp > 1 ) then + if ( SnowThickTmp(1) > 0.05 ) then ! maximum allowed thickness (5cm) for top snow layer + SnowThickCombTmp = SnowThickTmp(1) - 0.05 + SnowFracExtra = SnowThickCombTmp / SnowThickTmp(1) + SnowIceExtra = SnowFracExtra * SnowIceTmp(1) + SnowLiqExtra = SnowFracExtra * SnowLiqTmp(1) + SnowFracExtra = 0.05 / SnowThickTmp(1) + SnowIceTmp(1) = SnowFracExtra*SnowIceTmp(1) + SnowLiqTmp(1) = SnowFracExtra*SnowLiqTmp(1) + SnowThickTmp(1) = 0.05 + + ! update combined snow water & temperature + call SnowLayerWaterCombo(SnowThickTmp(2), SnowLiqTmp(2), SnowIceTmp(2), TemperatureSnowTmp(2), & + SnowThickCombTmp, SnowLiqExtra, SnowIceExtra, TemperatureSnowTmp(1)) + + ! subdivide a new layer, maximum allowed thickness (20cm) for second snow layer + if ( (NumSnowLayerTmp <= 2) .and. (SnowThickTmp(2) > 0.20) ) then ! MB: change limit + !if ( (NumSnowLayerTmp <= 2) .and. (SnowThickTmp(2) > 0.10) ) then + NumSnowLayerTmp = 3 + SnowTempGrad = (TemperatureSnowTmp(1) - TemperatureSnowTmp(2)) / & + ((SnowThickTmp(1)+SnowThickTmp(2)) / 2.0) + SnowThickTmp(2) = SnowThickTmp(2) / 2.0 + SnowIceTmp(2) = SnowIceTmp(2) / 2.0 + SnowLiqTmp(2) = SnowLiqTmp(2) / 2.0 + SnowThickTmp(3) = SnowThickTmp(2) + SnowIceTmp(3) = SnowIceTmp(2) + SnowLiqTmp(3) = SnowLiqTmp(2) + TemperatureSnowTmp(3) = TemperatureSnowTmp(2) - SnowTempGrad * SnowThickTmp(2) / 2.0 + if ( TemperatureSnowTmp(3) >= ConstFreezePoint ) then + TemperatureSnowTmp(3) = TemperatureSnowTmp(2) + else + TemperatureSnowTmp(2) = TemperatureSnowTmp(2) + SnowTempGrad * SnowThickTmp(2) / 2.0 + endif + endif + endif ! if(SnowThickTmp(1) > 0.05) + endif ! if (NumSnowLayerTmp > 1) + + if ( NumSnowLayerTmp > 2 ) then + if ( SnowThickTmp(2) > 0.2 ) then + SnowThickCombTmp = SnowThickTmp(2) - 0.2 + SnowFracExtra = SnowThickCombTmp / SnowThickTmp(2) + SnowIceExtra = SnowFracExtra * SnowIceTmp(2) + SnowLiqExtra = SnowFracExtra * SnowLiqTmp(2) + SnowFracExtra = 0.2 / SnowThickTmp(2) + SnowIceTmp(2) = SnowFracExtra * SnowIceTmp(2) + SnowLiqTmp(2) = SnowFracExtra * SnowLiqTmp(2) + SnowThickTmp(2) = 0.2 + + ! update combined snow water & temperature + call SnowLayerWaterCombo(SnowThickTmp(3), SnowLiqTmp(3), SnowIceTmp(3), TemperatureSnowTmp(3), & + SnowThickCombTmp, SnowLiqExtra, SnowIceExtra, TemperatureSnowTmp(2)) + endif + endif + + NumSnowLayerNeg = -NumSnowLayerTmp + + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = SnowThickTmp(LoopInd-NumSnowLayerNeg) + SnowIce(LoopInd) = SnowIceTmp(LoopInd-NumSnowLayerNeg) + SnowLiqWater(LoopInd) = SnowLiqTmp(LoopInd-NumSnowLayerNeg) + TemperatureSoilSnow(LoopInd) = TemperatureSnowTmp(LoopInd-NumSnowLayerNeg) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowIceTmp ) + deallocate(SnowLiqTmp ) + deallocate(TemperatureSnowTmp) + deallocate(SnowThickTmp ) + + end associate + + end subroutine SnowLayerDivide + +end module SnowLayerDivideMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerWaterComboMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerWaterComboMod.F90 new file mode 100644 index 0000000000..37c48d3d11 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowLayerWaterComboMod.F90 @@ -0,0 +1,70 @@ +module SnowLayerWaterComboMod + +!!! Update snow water and temperature for combined snowpack layer + + use Machine + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowLayerWaterCombo(ThickLayer1, LiqLayer1, IceLayer1, TempLayer1, & + ThickLayer2, LiqLayer2, IceLayer2, TempLayer2) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: COMBO +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! IN and OUT variables + real(kind=kind_noahmp), intent(in) :: ThickLayer2 ! nodal thickness of 2 elements being combined [m] + real(kind=kind_noahmp), intent(in) :: LiqLayer2 ! liquid water of element 2 [kg/m2] + real(kind=kind_noahmp), intent(in) :: IceLayer2 ! ice of element 2 [kg/m2] + real(kind=kind_noahmp), intent(in) :: TempLayer2 ! nodal temperature of element 2 [K] + real(kind=kind_noahmp), intent(inout) :: ThickLayer1 ! nodal thickness of 1 elements being combined [m] + real(kind=kind_noahmp), intent(inout) :: LiqLayer1 ! liquid water of element 1 + real(kind=kind_noahmp), intent(inout) :: IceLayer1 ! ice of element 1 [kg/m2] + real(kind=kind_noahmp), intent(inout) :: TempLayer1 ! node temperature of element 1 [K] + +! local variable + real(kind=kind_noahmp) :: ThickLayerComb ! total thickness of nodes 1 and 2 + real(kind=kind_noahmp) :: LiqLayerComb ! combined liquid water [kg/m2] + real(kind=kind_noahmp) :: IceLayerComb ! combined ice [kg/m2] + real(kind=kind_noahmp) :: TempLayerComb ! combined node temperature [K] + real(kind=kind_noahmp) :: EnthLayer1 ! enthalpy of element 1 [J/m2] + real(kind=kind_noahmp) :: EnthLayer2 ! enthalpy of element 2 [J/m2] + real(kind=kind_noahmp) :: EnthLayerComb ! combined enthalpy [J/m2] + +! ---------------------------------------------------------------------- + + ThickLayerComb = ThickLayer1 + ThickLayer2 + IceLayerComb = IceLayer1 + IceLayer2 + LiqLayerComb = LiqLayer1 + LiqLayer2 + EnthLayer1 = (ConstHeatCapacIce*IceLayer1 + ConstHeatCapacWater*LiqLayer1) * & + (TempLayer1-ConstFreezePoint) + ConstLatHeatFusion*LiqLayer1 + EnthLayer2 = (ConstHeatCapacIce*IceLayer2 + ConstHeatCapacWater*LiqLayer2) * & + (TempLayer2-ConstFreezePoint) + ConstLatHeatFusion*LiqLayer2 + + EnthLayerComb = EnthLayer1 + EnthLayer2 + if ( EnthLayerComb < 0.0 ) then + TempLayerComb = ConstFreezePoint + EnthLayerComb / & + (ConstHeatCapacIce*IceLayerComb + ConstHeatCapacWater*LiqLayerComb) + else if ( EnthLayerComb <= (ConstLatHeatFusion*LiqLayerComb) ) then + TempLayerComb = ConstFreezePoint + else + TempLayerComb = ConstFreezePoint + (EnthLayerComb-ConstLatHeatFusion*LiqLayerComb) / & + (ConstHeatCapacIce*IceLayerComb + ConstHeatCapacWater*LiqLayerComb) + endif + + ThickLayer1 = ThickLayerComb + IceLayer1 = IceLayerComb + LiqLayer1 = LiqLayerComb + TempLayer1 = TempLayerComb + + end subroutine SnowLayerWaterCombo + +end module SnowLayerWaterComboMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowThermalPropertyMod.F90 new file mode 100644 index 0000000000..6e6db9a7ef --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowThermalPropertyMod.F90 @@ -0,0 +1,85 @@ +module SnowThermalPropertyMod + +!!! Compute snowpack thermal conductivity and volumetric specific heat + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: CSNOW +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowDensBulk ! bulk density of snow [kg/m3] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptSnowThermConduct => noahmp%config%nmlist%OptSnowThermConduct ,& ! in, options for snow thermal conductivity schemes + SnowIce => noahmp%water%state%SnowIce ,& ! in, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! in, snow layer liquid water [mm] + SnowIceVol => noahmp%water%state%SnowIceVol ,& ! out, partial volume of snow ice [m3/m3] + SnowLiqWaterVol => noahmp%water%state%SnowLiqWaterVol ,& ! out, partial volume of snow liquid water [m3/m3] + SnowEffPorosity => noahmp%water%state%SnowEffPorosity ,& ! out, snow effective porosity [m3/m3] + HeatCapacVolSnow => noahmp%energy%state%HeatCapacVolSnow ,& ! out, snow layer volumetric specific heat [J/m3/K] + ThermConductSnow => noahmp%energy%state%ThermConductSnow & ! out, snow layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowDensBulk)) allocate(SnowDensBulk(-NumSnowLayerMax+1:0)) + SnowDensBulk = 0.0 + + ! effective porosity of snow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowIceVol(LoopInd) = min(1.0, SnowIce(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityIce)) + SnowEffPorosity(LoopInd) = 1.0 - SnowIceVol(LoopInd) + SnowLiqWaterVol(LoopInd) = min(SnowEffPorosity(LoopInd), & + SnowLiqWater(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityWater)) + enddo + + ! thermal capacity of snow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowDensBulk(LoopInd) = (SnowIce(LoopInd) + SnowLiqWater(LoopInd)) / ThicknessSnowSoilLayer(LoopInd) + HeatCapacVolSnow(LoopInd) = ConstHeatCapacIce*SnowIceVol(LoopInd) + ConstHeatCapacWater*SnowLiqWaterVol(LoopInd) + !HeatCapacVolSnow(LoopInd) = 0.525e06 ! constant + enddo + + ! thermal conductivity of snow + do LoopInd = NumSnowLayerNeg+1, 0 + if (OptSnowThermConduct == 1) & + ThermConductSnow(LoopInd) = 3.2217e-6 * SnowDensBulk(LoopInd)**2.0 ! Stieglitz(yen,1965) + if (OptSnowThermConduct == 2) & + ThermConductSnow(LoopInd) = 2e-2 + 2.5e-6*SnowDensBulk(LoopInd)*SnowDensBulk(LoopInd) ! Anderson, 1976 + if (OptSnowThermConduct == 3) & + ThermConductSnow(LoopInd) = 0.35 ! constant + if (OptSnowThermConduct == 4) & + ThermConductSnow(LoopInd) = 2.576e-6 * SnowDensBulk(LoopInd)**2.0 + 0.074 ! Verseghy (1991) + if (OptSnowThermConduct == 5) & + ThermConductSnow(LoopInd) = 2.22 * (SnowDensBulk(LoopInd)/1000.0)**1.88 ! Douvill(Yen, 1981) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowDensBulk) + + end associate + + end subroutine SnowThermalProperty + +end module SnowThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainGlacierMod.F90 new file mode 100644 index 0000000000..0fac6ec051 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainGlacierMod.F90 @@ -0,0 +1,141 @@ +module SnowWaterMainGlacierMod + +!!! Main glacier snow water module including all snowpack processes +!!! Snowfall -> Snowpack compaction -> Snow layer combination -> Snow layer division -> Snow Hydrology + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowfallBelowCanopyMod, only : SnowfallAfterCanopyIntercept + use SnowpackCompactionMod, only : SnowpackCompaction + use SnowLayerCombineMod, only : SnowLayerCombine + use SnowLayerDivideMod, only : SnowLayerDivide + use SnowpackHydrologyGlacierMod, only : SnowpackHydrologyGlacier + + implicit none + +contains + + subroutine SnowWaterMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWWATER_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: SnowDensBulk ! bulk density of snow [kg/m3] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SnoWatEqvMaxGlacier => noahmp%water%param%SnoWatEqvMaxGlacier ,& ! in, Maximum SWE allowed at glaciers [mm] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! inout, depth of snow/soil layer-bottom [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! out, glacier excess flow [mm/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize out-only variables + GlacierExcessFlow = 0.0 + PondSfcThinSnwComb = 0.0 + PondSfcThinSnwTrans = 0.0 + + ! snowfall + call SnowfallAfterCanopyIntercept(noahmp) + + ! do following snow layer compaction, combination, and division only for multi-layer snowpack + + ! snowpack compaction + if ( NumSnowLayerNeg < 0 ) call SnowpackCompaction(noahmp) + + ! snow layer combination + if ( NumSnowLayerNeg < 0 ) call SnowLayerCombine(noahmp) + + ! snow layer division + if ( NumSnowLayerNeg < 0 ) call SnowLayerDivide(noahmp) + + ! snow hydrology for all snow cases + call SnowpackHydrologyGlacier(noahmp) + + ! set empty snow layer properties to zero + do LoopInd = -NumSnowLayerMax+1, NumSnowLayerNeg + SnowIce(LoopInd) = 0.0 + SnowLiqWater(LoopInd) = 0.0 + TemperatureSoilSnow(LoopInd) = 0.0 + ThicknessSnowSoilLayer(LoopInd) = 0.0 + DepthSnowSoilLayer(LoopInd) = 0.0 + enddo + + ! to obtain equilibrium state of snow in glacier region + if ( SnowWaterEquiv > SnoWatEqvMaxGlacier ) then + SnowDensBulk = SnowIce(0) / ThicknessSnowSoilLayer(0) + GlacierExcessFlow = SnowWaterEquiv - SnoWatEqvMaxGlacier + SnowIce(0) = SnowIce(0) - GlacierExcessFlow + ThicknessSnowSoilLayer(0) = ThicknessSnowSoilLayer(0) - GlacierExcessFlow / SnowDensBulk + GlacierExcessFlow = GlacierExcessFlow / MainTimeStep + endif + + ! sum up snow mass for layered snow + if ( NumSnowLayerNeg < 0 ) then ! MB: only do for multi-layer + SnowWaterEquiv = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowWaterEquiv = SnowWaterEquiv + SnowIce(LoopInd) + SnowLiqWater(LoopInd) + enddo + endif + + ! Reset DepthSnowSoilLayer and ThicknessSnowSoilLayer + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ThicknessSnowSoilLayer(1) = DepthSoilLayer(1) + do LoopInd = 2, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = DepthSoilLayer(LoopInd) - DepthSoilLayer(LoopInd-1) + enddo + + DepthSnowSoilLayer(NumSnowLayerNeg+1) = ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + do LoopInd = NumSnowLayerNeg+2, NumSoilLayer + DepthSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) + ThicknessSnowSoilLayer(LoopInd) + enddo + + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ! Update SnowDepth for multi-layer snow + if ( NumSnowLayerNeg < 0 ) then + SnowDepth = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowDepth = SnowDepth + ThicknessSnowSoilLayer(LoopInd) + enddo + endif + + ! update snow quantity + if ( (SnowDepth <= 1.0e-6) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + end associate + + end subroutine SnowWaterMainGlacier + +end module SnowWaterMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainMod.F90 new file mode 100644 index 0000000000..2e3e7f00a6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowWaterMainMod.F90 @@ -0,0 +1,141 @@ +module SnowWaterMainMod + +!!! Main snow water module including all snowpack processes +!!! Snowfall -> Snowpack compaction -> Snow layer combination -> Snow layer division -> Snow Hydrology + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowfallBelowCanopyMod, only : SnowfallAfterCanopyIntercept + use SnowpackCompactionMod, only : SnowpackCompaction + use SnowLayerCombineMod, only : SnowLayerCombine + use SnowLayerDivideMod, only : SnowLayerDivide + use SnowpackHydrologyMod, only : SnowpackHydrology + + implicit none + +contains + + subroutine SnowWaterMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: SnowDensBulk ! bulk density of snow [kg/m3] + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SnoWatEqvMaxGlacier => noahmp%water%param%SnoWatEqvMaxGlacier ,& ! in, Maximum SWE allowed at glaciers [mm] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! inout, depth of snow/soil layer-bottom [m] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! out, glacier snow excess flow [mm/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize out-only variables + GlacierExcessFlow = 0.0 + PondSfcThinSnwComb = 0.0 + PondSfcThinSnwTrans = 0.0 + + ! snowfall after canopy interception + call SnowfallAfterCanopyIntercept(noahmp) + + ! do following snow layer compaction, combination, and division only for multi-layer snowpack + + ! snowpack compaction + if ( NumSnowLayerNeg < 0 ) call SnowpackCompaction(noahmp) + + ! snow layer combination + if ( NumSnowLayerNeg < 0 ) call SnowLayerCombine(noahmp) + + ! snow layer division + if ( NumSnowLayerNeg < 0 ) call SnowLayerDivide(noahmp) + + ! snow hydrology for all snow cases + call SnowpackHydrology(noahmp) + + ! set empty snow layer properties to zero + do LoopInd = -NumSnowLayerMax+1, NumSnowLayerNeg + SnowIce(LoopInd) = 0.0 + SnowLiqWater(LoopInd) = 0.0 + TemperatureSoilSnow(LoopInd) = 0.0 + ThicknessSnowSoilLayer(LoopInd) = 0.0 + DepthSnowSoilLayer(LoopInd) = 0.0 + enddo + + ! to obtain equilibrium state of snow in glacier region + if ( SnowWaterEquiv > SnoWatEqvMaxGlacier ) then + SnowDensBulk = SnowIce(0) / ThicknessSnowSoilLayer(0) + GlacierExcessFlow = SnowWaterEquiv - SnoWatEqvMaxGlacier + SnowIce(0) = SnowIce(0) - GlacierExcessFlow + ThicknessSnowSoilLayer(0) = ThicknessSnowSoilLayer(0) - GlacierExcessFlow / SnowDensBulk + GlacierExcessFlow = GlacierExcessFlow / MainTimeStep + endif + + ! sum up snow mass for layered snow + if ( NumSnowLayerNeg < 0 ) then ! MB: only do for multi-layer + SnowWaterEquiv = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowWaterEquiv = SnowWaterEquiv + SnowIce(LoopInd) + SnowLiqWater(LoopInd) + enddo + endif + + ! Reset DepthSnowSoilLayer and ThicknessSnowSoilLayer + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ThicknessSnowSoilLayer(1) = DepthSoilLayer(1) + do LoopInd = 2, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = DepthSoilLayer(LoopInd) - DepthSoilLayer(LoopInd-1) + enddo + + DepthSnowSoilLayer(NumSnowLayerNeg+1) = ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + do LoopInd = NumSnowLayerNeg+2, NumSoilLayer + DepthSnowSoilLayer(LoopInd) = DepthSnowSoilLayer(LoopInd-1) + ThicknessSnowSoilLayer(LoopInd) + enddo + + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + ThicknessSnowSoilLayer(LoopInd) = -ThicknessSnowSoilLayer(LoopInd) + enddo + + ! Update SnowDepth for multi-layer snow + if ( NumSnowLayerNeg < 0 ) then + SnowDepth = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + SnowDepth = SnowDepth + ThicknessSnowSoilLayer(LoopInd) + enddo + endif + + ! update snow quantity + if ( (SnowDepth <= 1.0e-6) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + end associate + + end subroutine SnowWaterMain + +end module SnowWaterMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowfallBelowCanopyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowfallBelowCanopyMod.F90 new file mode 100644 index 0000000000..5d37a407d6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowfallBelowCanopyMod.F90 @@ -0,0 +1,78 @@ +module SnowfallBelowCanopyMod + +!!! Snowfall process after canopy interception +!!! Update snow water equivalent and snow depth + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowfallAfterCanopyIntercept(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWFALL +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndNewSnowLayer ! 0-no new layers, 1-creating new layers + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! in, snowfall rate at ground [mm/s] + SnowDepthIncr => noahmp%water%flux%SnowDepthIncr ,& ! in, snow depth increasing rate [m/s] due to snowfall + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow & ! inout, snow and soil layer temperature [K] + ) +! ---------------------------------------------------------------------- + + IndNewSnowLayer = 0 + + ! shallow snow / no layer + if ( (NumSnowLayerNeg == 0) .and. (SnowfallGround > 0.0) ) then + SnowDepth = SnowDepth + SnowDepthIncr * MainTimeStep + SnowWaterEquiv = SnowWaterEquiv + SnowfallGround * MainTimeStep + endif + + ! creating a new layer + !if ( (NumSnowLayerNeg == 0) .and. (SnowfallGround > 0.0) .and. (SnowDepth >= 0.05) ) then + !if ( (NumSnowLayerNeg == 0) .and. (SnowfallGround > 0.0) .and. (SnowDepth >= 0.025) ) then !MB: change limit + ! C.He: remove SnowfallGround > 0.0 to allow adjusting snow layer number based on SnowDepth when no snowfall + if ( (NumSnowLayerNeg == 0) .and. (SnowDepth >= 0.025) ) then + NumSnowLayerNeg = -1 + IndNewSnowLayer = 1 + ThicknessSnowSoilLayer(0) = SnowDepth + SnowDepth = 0.0 + TemperatureSoilSnow(0) = min(273.16, TemperatureAirRefHeight) ! temporary setup + SnowIce(0) = SnowWaterEquiv + SnowLiqWater(0) = 0.0 + endif + + ! snow with layers + if ( (NumSnowLayerNeg < 0) .and. (IndNewSnowLayer == 0) .and. (SnowfallGround > 0.0) ) then + SnowIce(NumSnowLayerNeg+1) = SnowIce(NumSnowLayerNeg+1) + SnowfallGround * MainTimeStep + ThicknessSnowSoilLayer(NumSnowLayerNeg+1) = ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + & + SnowDepthIncr * MainTimeStep + endif + + end associate + + end subroutine SnowfallAfterCanopyIntercept + +end module SnowfallBelowCanopyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowpackCompactionMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackCompactionMod.F90 new file mode 100644 index 0000000000..05d59b0d7b --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackCompactionMod.F90 @@ -0,0 +1,126 @@ +module SnowpackCompactionMod + +!!! Snowpack compaction process +!!! Update snow depth via compaction due to destructive metamorphism, overburden, & melt + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SnowpackCompaction(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: COMPACT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! snow layer loop index + real(kind=kind_noahmp) :: SnowBurden ! pressure of overlying snow [kg/m2] + real(kind=kind_noahmp) :: SnowCompactAgeExpFac ! EXPF=exp(-c4*(273.15-TemperatureSoilSnow)) + real(kind=kind_noahmp) :: TempDiff ! ConstFreezePoint - TemperatureSoilSnow[K] + real(kind=kind_noahmp) :: SnowVoid ! void (1 - SnowIce - SnowLiqWater) + real(kind=kind_noahmp) :: SnowWatTotTmp ! water mass (ice + liquid) [kg/m2] + real(kind=kind_noahmp) :: SnowIceDens ! partial density of ice [kg/m3] + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + SnowIce => noahmp%water%state%SnowIce ,& ! in, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! in, snow layer liquid water [mm] + IndexPhaseChange => noahmp%water%state%IndexPhaseChange ,& ! in, phase change index [0-none;1-melt;2-refreeze] + SnowIceFracPrev => noahmp%water%state%SnowIceFracPrev ,& ! in, ice fraction in snow layers at previous timestep + SnowCompactBurdenFac => noahmp%water%param%SnowCompactBurdenFac ,& ! in, snow overburden compaction parameter [m3/kg] + SnowCompactAgingFac1 => noahmp%water%param%SnowCompactAgingFac1 ,& ! in, snow desctructive metamorphism compaction factor1 [1/s] + SnowCompactAgingFac2 => noahmp%water%param%SnowCompactAgingFac2 ,& ! in, snow desctructive metamorphism compaction factor2 [1/k] + SnowCompactAgingFac3 => noahmp%water%param%SnowCompactAgingFac3 ,& ! in, snow desctructive metamorphism compaction factor3 + SnowCompactAgingMax => noahmp%water%param%SnowCompactAgingMax ,& ! in, maximum destructive metamorphism compaction [kg/m3] + SnowViscosityCoeff => noahmp%water%param%SnowViscosityCoeff ,& ! in, snow viscosity coeff [kg s/m2],Anderson1979:0.52e6~1.38e6 + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + CompactionSnowAging => noahmp%water%flux%CompactionSnowAging ,& ! out, rate of compaction due to destructive metamorphism [1/s] + CompactionSnowBurden => noahmp%water%flux%CompactionSnowBurden ,& ! out, rate of compaction of snowpack due to overburden [1/s] + CompactionSnowMelt => noahmp%water%flux%CompactionSnowMelt ,& ! out, rate of compaction of snowpack due to melt [1/s] + CompactionSnowTot => noahmp%water%flux%CompactionSnowTot ,& ! out, change in fractional-thickness due to compaction [1/s] + SnowIceFrac => noahmp%water%state%SnowIceFrac & ! out, fraction of ice in snow layers at current time step + ) +! ---------------------------------------------------------------------- + +! initialization for out-only variables + CompactionSnowAging(:) = 0.0 + CompactionSnowBurden(:) = 0.0 + CompactionSnowMelt(:) = 0.0 + CompactionSnowTot(:) = 0.0 + SnowIceFrac(:) = 0.0 + +! start snow compaction + SnowBurden = 0.0 + do LoopInd = NumSnowLayerNeg+1, 0 + + SnowWatTotTmp = SnowIce(LoopInd) + SnowLiqWater(LoopInd) + SnowIceFrac(LoopInd) = SnowIce(LoopInd) / SnowWatTotTmp + SnowVoid = 1.0 - (SnowIce(LoopInd)/ConstDensityIce + SnowLiqWater(LoopInd)/ConstDensityWater) / & + ThicknessSnowSoilLayer(LoopInd) + + ! Allow compaction only for non-saturated node and higher ice lens node. + if ( (SnowVoid > 0.001) .and. (SnowIce(LoopInd) > 0.1) ) then + SnowIceDens = SnowIce(LoopInd) / ThicknessSnowSoilLayer(LoopInd) + TempDiff = max(0.0, ConstFreezePoint-TemperatureSoilSnow(LoopInd)) + + ! Settling/compaction as a result of destructive metamorphism + SnowCompactAgeExpFac = exp(-SnowCompactAgingFac2 * TempDiff) + CompactionSnowAging(LoopInd) = -SnowCompactAgingFac1 * SnowCompactAgeExpFac + if ( SnowIceDens > SnowCompactAgingMax ) & + CompactionSnowAging(LoopInd) = CompactionSnowAging(LoopInd) * exp(-46.0e-3*(SnowIceDens-SnowCompactAgingMax)) + if ( SnowLiqWater(LoopInd) > (0.01*ThicknessSnowSoilLayer(LoopInd)) ) & + CompactionSnowAging(LoopInd) = CompactionSnowAging(LoopInd) * SnowCompactAgingFac3 ! Liquid water term + + ! Compaction due to overburden + CompactionSnowBurden(LoopInd) = -(SnowBurden + 0.5*SnowWatTotTmp) * & + exp(-0.08*TempDiff-SnowCompactBurdenFac*SnowIceDens) / SnowViscosityCoeff ! 0.5*SnowWatTotTmp -> self-burden + + ! Compaction occurring during melt + if ( IndexPhaseChange(LoopInd) == 1 ) then + CompactionSnowMelt(LoopInd) = max(0.0, (SnowIceFracPrev(LoopInd)-SnowIceFrac(LoopInd)) / & + max(1.0e-6, SnowIceFracPrev(LoopInd))) + CompactionSnowMelt(LoopInd) = -CompactionSnowMelt(LoopInd) / MainTimeStep ! sometimes too large + else + CompactionSnowMelt(LoopInd) = 0.0 + endif + + ! Time rate of fractional change in snow thickness (units of s-1) + CompactionSnowTot(LoopInd) = (CompactionSnowAging(LoopInd) + CompactionSnowBurden(LoopInd) + & + CompactionSnowMelt(LoopInd) ) * MainTimeStep + CompactionSnowTot(LoopInd) = max(-0.5, CompactionSnowTot(LoopInd)) + + ! The change in DZ due to compaction + ThicknessSnowSoilLayer(LoopInd) = ThicknessSnowSoilLayer(LoopInd) * (1.0 + CompactionSnowTot(LoopInd)) + ThicknessSnowSoilLayer(LoopInd) = max(ThicknessSnowSoilLayer(LoopInd), & + SnowIce(LoopInd)/ConstDensityIce + SnowLiqWater(LoopInd)/ConstDensityWater) + + ! Constrain snow density to a reasonable range (50~500 kg/m3) + ThicknessSnowSoilLayer(LoopInd) = min( max( ThicknessSnowSoilLayer(LoopInd),& + (SnowIce(LoopInd)+SnowLiqWater(LoopInd))/500.0 ), & + (SnowIce(LoopInd)+SnowLiqWater(LoopInd))/50.0 ) + endif + + ! Pressure of overlying snow + SnowBurden = SnowBurden + SnowWatTotTmp + + enddo + + end associate + + end subroutine SnowpackCompaction + +end module SnowpackCompactionMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyGlacierMod.F90 new file mode 100644 index 0000000000..dc702ceaba --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyGlacierMod.F90 @@ -0,0 +1,169 @@ +module SnowpackHydrologyGlacierMod + +!!! Snowpack hydrology processes (sublimation/frost, evaporation/dew, meltwater) +!!! Update snowpack ice and liquid water content + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerCombineMod, only : SnowLayerCombine + + implicit none + +contains + + subroutine SnowpackHydrologyGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWH2O_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: InflowSnowLayer ! water flow into each snow layer (mm/s) + real(kind=kind_noahmp) :: OutflowSnowLayer ! water flow out of each snow layer (mm/s) + real(kind=kind_noahmp) :: SnowIceTmp ! ice mass after minus sublimation + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of SWE after frost & sublimation to original SWE + real(kind=kind_noahmp) :: SnowWaterTmp ! temporary SWE + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqVol ! partial volume of liquid water in layer + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceVol ! partial volume of ice lens in layer + +! -------------------------------------------------------------------- + associate( & + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, option for glacier treatment + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + HeatSensibleSfc => noahmp%energy%flux%HeatSensibleSfc ,& ! in, total sensible heat [W/m2] (+ to atm) + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! in, snow surface frost rate [mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! in, snow surface sublimation rate [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SnowLiqFracMax => noahmp%water%param%SnowLiqFracMax ,& ! in, maximum liquid water fraction in snow + SnowLiqHoldCap => noahmp%water%param%SnowLiqHoldCap ,& ! in, liquid water holding capacity for snowpack [m3/m3] + SnowLiqReleaseFac => noahmp%water%param%SnowLiqReleaseFac ,& ! in, snowpack water release timescale factor [1/s] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil liquid moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + SnowEffPorosity => noahmp%water%state%SnowEffPorosity ,& ! out, snow effective porosity [m3/m3] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow & ! out, total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowLiqVol)) allocate(SnowLiqVol(-NumSnowLayerMax+1:0)) + if (.not. allocated(SnowIceVol)) allocate(SnowIceVol(-NumSnowLayerMax+1:0)) + SnowLiqVol(:) = 0.0 + SnowIceVol(:) = 0.0 + SnowEffPorosity(:) = 0.0 + SnowBotOutflow = 0.0 + InflowSnowLayer = 0.0 + OutflowSnowLayer = 0.0 + + ! for the case when SnowWaterEquiv becomes '0' after 'COMBINE' + if ( SnowWaterEquiv == 0.0 ) then + if ( OptGlacierTreatment == 1 ) then + SoilIce(1) = SoilIce(1) + (FrostSnowSfcIce-SublimSnowSfcIce) * MainTimeStep / & + (ThicknessSnowSoilLayer(1)*1000.0) ! Barlage: SoilLiqWater->SoilIce v3.6 + elseif ( OptGlacierTreatment == 2 ) then + HeatSensibleSfc = HeatSensibleSfc - (FrostSnowSfcIce - SublimSnowSfcIce) * ConstLatHeatSublim + FrostSnowSfcIce = 0.0 + SublimSnowSfcIce = 0.0 + endif + endif + + ! for shallow snow without a layer + ! snow surface sublimation may be larger than existing snow mass. To conserve water, + ! excessive sublimation is used to reduce soil water. Smaller time steps would tend to aviod this problem. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) ) then + if ( OptGlacierTreatment == 1 ) then + SnowWaterTmp = SnowWaterEquiv + SnowWaterEquiv = SnowWaterEquiv - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowWaterRatio = SnowWaterEquiv / SnowWaterTmp + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth) + SnowDepth = min(max(SnowDepth, SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit adjustment to a reasonable density + elseif ( OptGlacierTreatment == 2 ) then + HeatSensibleSfc = HeatSensibleSfc - (FrostSnowSfcIce - SublimSnowSfcIce) * ConstLatHeatSublim + FrostSnowSfcIce = 0.0 + SublimSnowSfcIce = 0.0 + endif + if ( SnowWaterEquiv < 0.0 ) then + SoilIce(1) = SoilIce(1) + SnowWaterEquiv / (ThicknessSnowSoilLayer(1)*1000.0) + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + endif + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + endif + + if ( (SnowDepth <= 1.0e-8) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + ! for multi-layer (>=1) snow + if ( NumSnowLayerNeg < 0 ) then + SnowIceTmp = SnowIce(NumSnowLayerNeg+1) - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowIce(NumSnowLayerNeg+1) = SnowIceTmp + if ( (SnowIceTmp < 1.0e-6) .and. (NumSnowLayerNeg < 0) ) call SnowLayerCombine(noahmp) + if ( NumSnowLayerNeg < 0 ) then + SnowLiqWater(NumSnowLayerNeg+1) = SnowLiqWater(NumSnowLayerNeg+1) + RainfallGround * MainTimeStep + SnowLiqWater(NumSnowLayerNeg+1) = max(0.0, SnowLiqWater(NumSnowLayerNeg+1)) + endif + endif + + ! Porosity and partial volume + do LoopInd = NumSnowLayerNeg+1, 0 + SnowIceVol(LoopInd) = min(1.0, SnowIce(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityIce)) + SnowEffPorosity(LoopInd) = 1.0 - SnowIceVol(LoopInd) + enddo + + ! compute inter-layer snow water flow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) + InflowSnowLayer + SnowLiqVol(LoopInd) = SnowLiqWater(LoopInd) / (ThicknessSnowSoilLayer(LoopInd)*ConstDensityWater) + OutflowSnowLayer = max(0.0, (SnowLiqVol(LoopInd) - SnowLiqHoldCap*SnowEffPorosity(LoopInd)) * & + ThicknessSnowSoilLayer(LoopInd)) + if ( LoopInd == 0 ) then + OutflowSnowLayer = max((SnowLiqVol(LoopInd)-SnowEffPorosity(LoopInd)) * ThicknessSnowSoilLayer(LoopInd), & + SnowLiqReleaseFac * MainTimeStep * OutflowSnowLayer) + endif + OutflowSnowLayer = OutflowSnowLayer * ConstDensityWater + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) - OutflowSnowLayer + if ( ( SnowLiqWater(LoopInd) / (SnowIce(LoopInd)+SnowLiqWater(LoopInd)) ) > SnowLiqFracMax ) then + OutflowSnowLayer = OutflowSnowLayer + & + (SnowLiqWater(LoopInd) - SnowLiqFracMax/(1.0-SnowLiqFracMax) * SnowIce(LoopInd)) + SnowLiqWater(LoopInd) = SnowLiqFracMax / (1.0 - SnowLiqFracMax) * SnowIce(LoopInd) + endif + InflowSnowLayer = OutflowSnowLayer + enddo + + ! update snow depth + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = max(ThicknessSnowSoilLayer(LoopInd), & + SnowLiqWater(LoopInd)/ConstDensityWater + SnowIce(LoopInd)/ConstDensityIce) + enddo + + ! Liquid water from snow bottom to soil (mm/s) + SnowBotOutflow = OutflowSnowLayer / MainTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowLiqVol) + deallocate(SnowIceVol) + + end associate + + end subroutine SnowpackHydrologyGlacier + +end module SnowpackHydrologyGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyMod.F90 new file mode 100644 index 0000000000..8b3638d4e2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SnowpackHydrologyMod.F90 @@ -0,0 +1,159 @@ +module SnowpackHydrologyMod + +!!! Snowpack hydrology processes (sublimation/frost, evaporation/dew, meltwater) +!!! Update snowpack ice and liquid water content + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowLayerCombineMod, only : SnowLayerCombine + + implicit none + +contains + + subroutine SnowpackHydrology(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SNOWH2O +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do loop/array indices + real(kind=kind_noahmp) :: InflowSnowLayer ! water flow into each snow layer [mm/s] + real(kind=kind_noahmp) :: OutflowSnowLayer ! water flow out of each snow layer [mm/s] + real(kind=kind_noahmp) :: SnowIceTmp ! ice mass after minus sublimation + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of SWE after frost & sublimation to original SWE + real(kind=kind_noahmp) :: SnowWaterTmp ! temporary SWE + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqVol ! partial volume of liquid water in layer + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceVol ! partial volume of ice lens in layer + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! in, snow surface frost rate [mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! in, snow surface sublimation rate [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SnowLiqFracMax => noahmp%water%param%SnowLiqFracMax ,& ! in, maximum liquid water fraction in snow + SnowLiqHoldCap => noahmp%water%param%SnowLiqHoldCap ,& ! in, liquid water holding capacity for snowpack [m3/m3] + SnowLiqReleaseFac => noahmp%water%param%SnowLiqReleaseFac ,& ! in, snowpack water release timescale factor [1/s] + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil liquid moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + SnowEffPorosity => noahmp%water%state%SnowEffPorosity ,& ! out, snow effective porosity [m3/m3] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow & ! out, total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(SnowLiqVol)) allocate(SnowLiqVol(-NumSnowLayerMax+1:0)) + if (.not. allocated(SnowIceVol)) allocate(SnowIceVol(-NumSnowLayerMax+1:0)) + SnowLiqVol(:) = 0.0 + SnowIceVol(:) = 0.0 + SnowEffPorosity(:) = 0.0 + SnowBotOutflow = 0.0 + InflowSnowLayer = 0.0 + OutflowSnowLayer = 0.0 + + ! for the case when SnowWaterEquiv becomes '0' after 'COMBINE' + if ( SnowWaterEquiv == 0.0 ) then + SoilIce(1) = SoilIce(1) + (FrostSnowSfcIce-SublimSnowSfcIce) * MainTimeStep / & + (ThicknessSnowSoilLayer(1)*1000.0) ! Barlage: SoilLiqWater->SoilIce v3.6 + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + endif + + ! for shallow snow without a layer + ! snow surface sublimation may be larger than existing snow mass. To conserve water, + ! excessive sublimation is used to reduce soil water. Smaller time steps would tend to aviod this problem. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) ) then + SnowWaterTmp = SnowWaterEquiv + SnowWaterEquiv = SnowWaterEquiv - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowWaterRatio = SnowWaterEquiv / SnowWaterTmp + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth ) + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit adjustment to a reasonable density + if ( SnowWaterEquiv < 0.0 ) then + SoilIce(1) = SoilIce(1) + SnowWaterEquiv / (ThicknessSnowSoilLayer(1)*1000.0) + SnowWaterEquiv = 0.0 + SnowDepth = 0.0 + endif + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + endif + + if ( (SnowDepth <= 1.0e-8) .or. (SnowWaterEquiv <= 1.0e-6) ) then + SnowDepth = 0.0 + SnowWaterEquiv = 0.0 + endif + + ! for multi-layer (>=1) snow + if ( NumSnowLayerNeg < 0 ) then + SnowIceTmp = SnowIce(NumSnowLayerNeg+1) - SublimSnowSfcIce*MainTimeStep + FrostSnowSfcIce*MainTimeStep + SnowIce(NumSnowLayerNeg+1) = SnowIceTmp + if ( (SnowIceTmp < 1.0e-6) .and. (NumSnowLayerNeg < 0) ) call SnowLayerCombine(noahmp) + if ( NumSnowLayerNeg < 0 ) then + SnowLiqWater(NumSnowLayerNeg+1) = SnowLiqWater(NumSnowLayerNeg+1) + RainfallGround * MainTimeStep + SnowLiqWater(NumSnowLayerNeg+1) = max(0.0, SnowLiqWater(NumSnowLayerNeg+1)) + endif + endif + + ! Porosity and partial volume + do LoopInd = NumSnowLayerNeg+1, 0 + SnowIceVol(LoopInd) = min(1.0, SnowIce(LoopInd)/(ThicknessSnowSoilLayer(LoopInd)*ConstDensityIce)) + SnowEffPorosity(LoopInd) = 1.0 - SnowIceVol(LoopInd) + enddo + + ! compute inter-layer snow water flow + do LoopInd = NumSnowLayerNeg+1, 0 + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) + InflowSnowLayer + SnowLiqVol(LoopInd) = SnowLiqWater(LoopInd) / (ThicknessSnowSoilLayer(LoopInd)*ConstDensityWater) + OutflowSnowLayer = max(0.0, (SnowLiqVol(LoopInd)-SnowLiqHoldCap*SnowEffPorosity(LoopInd)) * & + ThicknessSnowSoilLayer(LoopInd)) + if ( LoopInd == 0 ) then + OutflowSnowLayer = max((SnowLiqVol(LoopInd)-SnowEffPorosity(LoopInd)) * ThicknessSnowSoilLayer(LoopInd), & + SnowLiqReleaseFac * MainTimeStep * OutflowSnowLayer) + endif + OutflowSnowLayer = OutflowSnowLayer * ConstDensityWater + SnowLiqWater(LoopInd) = SnowLiqWater(LoopInd) - OutflowSnowLayer + if ( (SnowLiqWater(LoopInd)/(SnowIce(LoopInd)+SnowLiqWater(LoopInd))) > SnowLiqFracMax ) then + OutflowSnowLayer = OutflowSnowLayer + (SnowLiqWater(LoopInd) - & + SnowLiqFracMax / (1.0-SnowLiqFracMax) * SnowIce(LoopInd)) + SnowLiqWater(LoopInd) = SnowLiqFracMax / (1.0 - SnowLiqFracMax) * SnowIce(LoopInd) + endif + InflowSnowLayer = OutflowSnowLayer + enddo + + ! update snow depth + do LoopInd = NumSnowLayerNeg+1, 0 + ThicknessSnowSoilLayer(LoopInd) = max(ThicknessSnowSoilLayer(LoopInd), & + SnowLiqWater(LoopInd)/ConstDensityWater+SnowIce(LoopInd)/ConstDensityIce) + enddo + + ! Liquid water from snow bottom to soil [mm/s] + SnowBotOutflow = OutflowSnowLayer / MainTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(SnowLiqVol) + deallocate(SnowIceVol) + + end associate + + end subroutine SnowpackHydrology + +end module SnowpackHydrologyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilHydraulicPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilHydraulicPropertyMod.F90 new file mode 100644 index 0000000000..438624f5c0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilHydraulicPropertyMod.F90 @@ -0,0 +1,118 @@ +module SoilHydraulicPropertyMod + +!!! Two methods for calculating soil water diffusivity and soil hydraulic conductivity +!!! Option 1: linear effects (more permeable, Niu and Yang,2006); Option 2: nonlinear effects (less permeable) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilDiffusivityConductivityOpt1(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture, SoilImpervFrac, IndLayer) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: WDFCND1 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN and OUT variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndLayer ! soil layer index + real(kind=kind_noahmp), intent(in) :: SoilMoisture ! soil moisture [m3/m3] + real(kind=kind_noahmp), intent(in) :: SoilImpervFrac ! impervious fraction due to frozen soil + real(kind=kind_noahmp), intent(out) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp), intent(out) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + +! local variable + real(kind=kind_noahmp) :: SoilExpTmp ! exponential local factor + real(kind=kind_noahmp) :: SoilPreFac ! pre-factor + +! -------------------------------------------------------------------- + associate( & + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + SoilPreFac = max(0.01, SoilMoisture/SoilMoistureSat(IndLayer)) + + ! soil water diffusivity + SoilExpTmp = SoilExpCoeffB(IndLayer) + 2.0 + SoilWatDiffusivity = SoilWatDiffusivitySat(IndLayer) * SoilPreFac ** SoilExpTmp + SoilWatDiffusivity = SoilWatDiffusivity * (1.0 - SoilImpervFrac) + + ! soil hydraulic conductivity + SoilExpTmp = 2.0 * SoilExpCoeffB(IndLayer) + 3.0 + SoilWatConductivity = SoilWatConductivitySat(IndLayer) * SoilPreFac ** SoilExpTmp + SoilWatConductivity = SoilWatConductivity * (1.0 - SoilImpervFrac) + + end associate + + end subroutine SoilDiffusivityConductivityOpt1 + + + subroutine SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture, SoilIce, IndLayer) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: WDFCND2 +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! IN and OUT variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndLayer ! soil layer index + real(kind=kind_noahmp), intent(in) :: SoilMoisture ! soil moisture [m3/m3] + real(kind=kind_noahmp), intent(in) :: SoilIce ! soil ice content [m3/m3] + real(kind=kind_noahmp), intent(out) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp), intent(out) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + +! local variable + real(kind=kind_noahmp) :: SoilExpTmp ! exponential local factor + real(kind=kind_noahmp) :: SoilPreFac1 ! pre-factor + real(kind=kind_noahmp) :: SoilPreFac2 ! pre-factor + real(kind=kind_noahmp) :: SoilIceWgt ! weights + +! -------------------------------------------------------------------- + associate( & + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + SoilPreFac1 = 0.05 / SoilMoistureSat(IndLayer) + SoilPreFac2 = max(0.01, SoilMoisture/SoilMoistureSat(IndLayer)) + SoilPreFac1 = min(SoilPreFac1, SoilPreFac2) + + ! soil water diffusivity + SoilExpTmp = SoilExpCoeffB(IndLayer) + 2.0 + SoilWatDiffusivity = SoilWatDiffusivitySat(IndLayer) * SoilPreFac2 ** SoilExpTmp + if ( SoilIce > 0.0 ) then + SoilIceWgt = 1.0 / (1.0 + (500.0 * SoilIce)**3.0) + SoilWatDiffusivity = SoilIceWgt * SoilWatDiffusivity + & + (1.0-SoilIceWgt) * SoilWatDiffusivitySat(IndLayer) * SoilPreFac1**SoilExpTmp + endif + + ! soil hydraulic conductivity + SoilExpTmp = 2.0 * SoilExpCoeffB(IndLayer) + 3.0 + SoilWatConductivity = SoilWatConductivitySat(IndLayer) * SoilPreFac2 ** SoilExpTmp + + end associate + + end subroutine SoilDiffusivityConductivityOpt2 + +end module SoilHydraulicPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilMoistureSolverMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilMoistureSolverMod.F90 new file mode 100644 index 0000000000..b7ac40166d --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilMoistureSolverMod.F90 @@ -0,0 +1,148 @@ +module SoilMoistureSolverMod + +!!! Compute soil moisture content using based on Richards diffusion & tri-diagonal matrix +!!! Dependent on the output from SoilWaterDiffusionRichards subroutine + + use Machine + use NoahmpVarType + use ConstantDefineMod + use MatrixSolverTriDiagonalMod, only : MatrixSolverTriDiagonal + + implicit none + +contains + + subroutine SoilMoistureSolver(noahmp, TimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SSTEP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! soil layer loop index + real(kind=kind_noahmp) :: WatDefiTmp ! temporary water deficiency + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRightTmp ! temporary MatRight matrix coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3Tmp ! temporary MatLeft3 matrix coefficient + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptRunoffSubsurface => noahmp%config%nmlist%OptRunoffSubsurface ,& ! in, options for drainage and subsurface runoff + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + SoilMoistureToWT => noahmp%water%state%SoilMoistureToWT ,& ! inout, soil moisture between bottom of soil & water table + RechargeGwDeepWT => noahmp%water%state%RechargeGwDeepWT ,& ! inout, recharge to or from the water table when deep [m] + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! inout, soil bottom drainage (m/s) + SoilEffPorosity => noahmp%water%state%SoilEffPorosity ,& ! out, soil effective porosity (m3/m3) + SoilSaturationExcess => noahmp%water%state%SoilSaturationExcess & ! out, saturation excess of the total soil [m] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRightTmp)) allocate(MatRightTmp(1:NumSoilLayer)) + if (.not. allocated(MatLeft3Tmp)) allocate(MatLeft3Tmp(1:NumSoilLayer)) + MatRightTmp = 0.0 + MatLeft3Tmp = 0.0 + SoilSaturationExcess = 0.0 + SoilEffPorosity(:) = 0.0 + + ! update tri-diagonal matrix elements + do LoopInd = 1, NumSoilLayer + MatRight(LoopInd) = MatRight(LoopInd) * TimeStep + MatLeft1(LoopInd) = MatLeft1(LoopInd) * TimeStep + MatLeft2(LoopInd) = 1.0 + MatLeft2(LoopInd) * TimeStep + MatLeft3(LoopInd) = MatLeft3(LoopInd) * TimeStep + enddo + + ! copy values for input variables before calling rosr12 + do LoopInd = 1, NumSoilLayer + MatRightTmp(LoopInd) = MatRight(LoopInd) + MatLeft3Tmp(LoopInd) = MatLeft3(LoopInd) + enddo + + ! call ROSR12 to solve the tri-diagonal matrix + call MatrixSolverTriDiagonal(MatLeft3,MatLeft1,MatLeft2,MatLeft3Tmp,MatRightTmp,MatRight,1,NumSoilLayer,0) + + do LoopInd = 1, NumSoilLayer + SoilLiqWater(LoopInd) = SoilLiqWater(LoopInd) + MatLeft3(LoopInd) + enddo + + ! excessive water above saturation in a layer is moved to + ! its unsaturated layer like in a bucket + + ! for MMF scheme, there is soil moisture below NumSoilLayer, to the water table + if ( OptRunoffSubsurface == 5 ) then + ! update SoilMoistureToWT + if ( WaterTableDepth < (DepthSoilLayer(NumSoilLayer)-ThicknessSnowSoilLayer(NumSoilLayer)) ) then + ! accumulate soil drainage to update deep water table and soil moisture later + RechargeGwDeepWT = RechargeGwDeepWT + TimeStep * DrainSoilBot + else + SoilMoistureToWT = SoilMoistureToWT + & + TimeStep * DrainSoilBot / ThicknessSnowSoilLayer(NumSoilLayer) + SoilSaturationExcess = max((SoilMoistureToWT - SoilMoistureSat(NumSoilLayer)), 0.0) * & + ThicknessSnowSoilLayer(NumSoilLayer) + WatDefiTmp = max((1.0e-4 - SoilMoistureToWT), 0.0) * ThicknessSnowSoilLayer(NumSoilLayer) + SoilMoistureToWT = max(min(SoilMoistureToWT, SoilMoistureSat(NumSoilLayer)), 1.0e-4) + SoilLiqWater(NumSoilLayer) = SoilLiqWater(NumSoilLayer) + & + SoilSaturationExcess / ThicknessSnowSoilLayer(NumSoilLayer) + ! reduce fluxes at the bottom boundaries accordingly + DrainSoilBot = DrainSoilBot - SoilSaturationExcess/TimeStep + RechargeGwDeepWT = RechargeGwDeepWT - WatDefiTmp + endif + endif + + do LoopInd = NumSoilLayer, 2, -1 + SoilEffPorosity(LoopInd) = max(1.0e-4, (SoilMoistureSat(LoopInd) - SoilIce(LoopInd))) + SoilSaturationExcess = max((SoilLiqWater(LoopInd)-SoilEffPorosity(LoopInd)), 0.0) * & + ThicknessSnowSoilLayer(LoopInd) + SoilLiqWater(LoopInd) = min(SoilEffPorosity(LoopInd), SoilLiqWater(LoopInd) ) + SoilLiqWater(LoopInd-1) = SoilLiqWater(LoopInd-1) + SoilSaturationExcess / ThicknessSnowSoilLayer(LoopInd-1) + enddo + + SoilEffPorosity(1) = max(1.0e-4, (SoilMoistureSat(1)-SoilIce(1))) + SoilSaturationExcess = max((SoilLiqWater(1)-SoilEffPorosity(1)), 0.0) * ThicknessSnowSoilLayer(1) + SoilLiqWater(1) = min(SoilEffPorosity(1), SoilLiqWater(1)) + + if ( SoilSaturationExcess > 0.0 ) then + SoilLiqWater(2) = SoilLiqWater(2) + SoilSaturationExcess / ThicknessSnowSoilLayer(2) + do LoopInd = 2, NumSoilLayer-1 + SoilEffPorosity(LoopInd) = max(1.0e-4, (SoilMoistureSat(LoopInd) - SoilIce(LoopInd))) + SoilSaturationExcess = max((SoilLiqWater(LoopInd)-SoilEffPorosity(LoopInd)), 0.0) * & + ThicknessSnowSoilLayer(LoopInd) + SoilLiqWater(LoopInd) = min(SoilEffPorosity(LoopInd), SoilLiqWater(LoopInd)) + SoilLiqWater(LoopInd+1) = SoilLiqWater(LoopInd+1) + SoilSaturationExcess / ThicknessSnowSoilLayer(LoopInd+1) + enddo + SoilEffPorosity(NumSoilLayer) = max(1.0e-4, (SoilMoistureSat(NumSoilLayer) - SoilIce(NumSoilLayer))) + SoilSaturationExcess = max((SoilLiqWater(NumSoilLayer)-SoilEffPorosity(NumSoilLayer)), 0.0) * & + ThicknessSnowSoilLayer(NumSoilLayer) + SoilLiqWater(NumSoilLayer) = min(SoilEffPorosity(NumSoilLayer), SoilLiqWater(NumSoilLayer)) + endif + + SoilMoisture = SoilLiqWater + SoilIce + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRightTmp) + deallocate(MatLeft3Tmp) + + end associate + + end subroutine SoilMoistureSolver + +end module SoilMoistureSolverMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureMainMod.F90 new file mode 100644 index 0000000000..cf4a906b2a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureMainMod.F90 @@ -0,0 +1,84 @@ +module SoilSnowTemperatureMainMod + +!!! Main module to compute snow (if exists) and soil layer temperature. +!!! Note that snow temperatures during melting season may exceed melting +!!! point but later in SoilSnowPhaseChange subroutine the snow +!!! temperatures are reset to melting point for melting snow. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilSnowTemperatureSolverMod, only : SoilSnowTemperatureSolver + use SoilSnowThermalDiffusionMod, only : SoilSnowThermalDiffusion + + implicit none + +contains + + subroutine SoilSnowTemperatureMain(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TSNOSOI +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft1 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft2 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3 ! left-hand side term + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil process timestep [s] + DepthSoilTempBottom => noahmp%config%domain%DepthSoilTempBottom ,& ! in, depth [m] from soil surface for soil temp. lower boundary + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! out, depth [m] of soil temp. lower boundary from snow surface + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot ,& ! out, energy influx from soil bottom during soil timestep [J/m2] + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd & ! out, light penetrating through soil/snow water [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRight)) allocate(MatRight(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft1)) allocate(MatLeft1(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft2)) allocate(MatLeft2(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3)) allocate(MatLeft3(-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + + ! compute solar penetration through water, needs more work + RadSwPenetrateGrd(NumSnowLayerNeg+1:NumSoilLayer) = 0.0 + + ! adjust DepthSoilTempBottom from soil surface to DepthSoilTempBotToSno from snow surface + DepthSoilTempBotToSno = DepthSoilTempBottom - SnowDepth + + ! compute soil temperatures + call SoilSnowThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + call SoilSnowTemperatureSolver(noahmp, SoilTimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + + ! accumulate soil bottom flux for soil timestep + HeatFromSoilBot = HeatFromSoilBot * SoilTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRight) + deallocate(MatLeft1) + deallocate(MatLeft2) + deallocate(MatLeft3) + + end associate + + end subroutine SoilSnowTemperatureMain + +end module SoilSnowTemperatureMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureSolverMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureSolverMod.F90 new file mode 100644 index 0000000000..1a42889080 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowTemperatureSolverMod.F90 @@ -0,0 +1,84 @@ +module SoilSnowTemperatureSolverMod + +!!! Compute soil and snow layer temperature using tri-diagonal matrix solution +!!! Dependent on the output from SoilSnowThermalDiffusion subroutine + + use Machine + use NoahmpVarType + use ConstantDefineMod + use MatrixSolverTriDiagonalMod, only : MatrixSolverTriDiagonal + + implicit none + +contains + + subroutine SoilSnowTemperatureSolver(noahmp, TimeStep, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HSTEP +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! layer loop index + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRightTmp ! temporary MatRight matrix coefficient + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3Tmp ! temporary MatLeft3 matrix coefficient + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow & ! inout, snow and soil layer temperature [K] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRightTmp)) allocate(MatRightTmp(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MatLeft3Tmp)) allocate(MatLeft3Tmp(-NumSnowLayerMax+1:NumSoilLayer)) + MatRightTmp = 0.0 + MatLeft3Tmp = 0.0 + + ! update tri-diagonal matrix elements + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRight(LoopInd) = MatRight(LoopInd) * TimeStep + MatLeft1(LoopInd) = MatLeft1(LoopInd) * TimeStep + MatLeft2(LoopInd) = 1.0 + MatLeft2(LoopInd) * TimeStep + MatLeft3(LoopInd) = MatLeft3(LoopInd) * TimeStep + enddo + + ! copy values for input variables before call to rosr12 + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + MatRightTmp(LoopInd) = MatRight(LoopInd) + MatLeft3Tmp(LoopInd) = MatLeft3(LoopInd) + enddo + + ! solve the tri-diagonal matrix equation + call MatrixSolverTriDiagonal(MatLeft3,MatLeft1,MatLeft2,MatLeft3Tmp,MatRightTmp,& + MatRight,NumSnowLayerNeg+1,NumSoilLayer,NumSnowLayerMax) + + ! update snow & soil temperature + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + TemperatureSoilSnow(LoopInd) = TemperatureSoilSnow(LoopInd) + MatLeft3(LoopInd) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRightTmp) + deallocate(MatLeft3Tmp) + + end associate + + end subroutine SoilSnowTemperatureSolver + +end module SoilSnowTemperatureSolverMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowThermalDiffusionMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowThermalDiffusionMod.F90 new file mode 100644 index 0000000000..9655b77d50 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowThermalDiffusionMod.F90 @@ -0,0 +1,141 @@ +module SoilSnowThermalDiffusionMod + +!!! Solve soil and snow layer thermal diffusion +!!! Calculate the right hand side of the time tendency term of the soil +!!! and snow thermal diffusion equation. Currently snow and soil layers +!!! are coupled in solving the equations. Also compute/prepare the matrix +!!! coefficients for the tri-diagonal matrix of the implicit time scheme. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilSnowThermalDiffusion(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: HRT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: DepthSnowSoilTmp ! temporary snow/soil layer depth [m] + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilInv ! inverse of snow/soil layer depth [1/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: HeatCapacPerArea ! Heat capacity of soil/snow per area [J/m2/K] + real(kind=kind_noahmp), allocatable, dimension(:) :: TempGradDepth ! temperature gradient (derivative) with soil/snow depth [K/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyExcess ! energy flux excess in soil/snow [W/m2] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + DepthSnowSoilLayer => noahmp%config%domain%DepthSnowSoilLayer ,& ! in, depth of snow/soil layer-bottom [m] + OptSoilTemperatureBottom => noahmp%config%nmlist%OptSoilTemperatureBottom ,& ! in, options for lower boundary condition of soil temp. + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme + TemperatureSoilBottom => noahmp%forcing%TemperatureSoilBottom ,& ! in, bottom boundary soil temperature [K] + DepthSoilTempBotToSno => noahmp%energy%state%DepthSoilTempBotToSno ,& ! in, depth of lower boundary condition [m] from snow surface + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + HeatCapacSoilSnow => noahmp%energy%state%HeatCapacSoilSnow ,& ! in, heat capacity [J/m3/K] for all soil & snow + HeatGroundTotMean => noahmp%energy%flux%HeatGroundTotMean ,& ! in, total ground heat flux [W/m2] averaged during soil timestep + RadSwPenetrateGrd => noahmp%energy%flux%RadSwPenetrateGrd ,& ! in, light penetrating through soil/snow water [W/m2] + HeatFromSoilBot => noahmp%energy%flux%HeatFromSoilBot & ! out, energy influx from soil bottom [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSnowSoilInv)) allocate(DepthSnowSoilInv(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(HeatCapacPerArea)) allocate(HeatCapacPerArea(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(TempGradDepth) ) allocate(TempGradDepth (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(EnergyExcess) ) allocate(EnergyExcess (-NumSnowLayerMax+1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + DepthSnowSoilInv(:) = 0.0 + HeatCapacPerArea(:) = 0.0 + TempGradDepth(:) = 0.0 + EnergyExcess(:) = 0.0 + + ! compute gradient and flux of soil/snow thermal diffusion + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + HeatCapacPerArea(LoopInd) = - DepthSnowSoilLayer(LoopInd) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) - & + HeatGroundTotMean - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd < NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + TempGradDepth(LoopInd) = 2.0 * (TemperatureSoilSnow(LoopInd) - TemperatureSoilSnow(LoopInd+1)) / DepthSnowSoilTmp + EnergyExcess(LoopInd) = (ThermConductSoilSnow(LoopInd)*TempGradDepth(LoopInd) - & + ThermConductSoilSnow(LoopInd-1) * TempGradDepth(LoopInd-1) ) - RadSwPenetrateGrd(LoopInd) + elseif ( LoopInd == NumSoilLayer ) then + HeatCapacPerArea(LoopInd) = (DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd)) * HeatCapacSoilSnow(LoopInd) + DepthSnowSoilTmp = DepthSnowSoilLayer(LoopInd-1) - DepthSnowSoilLayer(LoopInd) + if ( OptSoilTemperatureBottom == 1 ) then + HeatFromSoilBot = 0.0 + endif + if ( OptSoilTemperatureBottom == 2 ) then + TempGradDepth(LoopInd) = (TemperatureSoilSnow(LoopInd) - TemperatureSoilBottom) / & + (0.5*(DepthSnowSoilLayer(LoopInd-1)+DepthSnowSoilLayer(LoopInd)) - DepthSoilTempBotToSno) + HeatFromSoilBot = -ThermConductSoilSnow(LoopInd) * TempGradDepth(LoopInd) + endif + EnergyExcess(LoopInd) = (-HeatFromSoilBot - ThermConductSoilSnow(LoopInd-1) * TempGradDepth(LoopInd-1)) - & + RadSwPenetrateGrd(LoopInd) + endif + enddo + + ! prepare the matrix coefficients for the tri-diagonal matrix + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( LoopInd == (NumSnowLayerNeg+1) ) then + MatLeft1(LoopInd) = 0.0 + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd) * DepthSnowSoilInv(LoopInd) / HeatCapacPerArea(LoopInd) + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + endif + if ( OptSnowSoilTempTime == 2 ) then + MatLeft2(LoopInd) = - MatLeft3(LoopInd) + ThermConductSoilSnow(LoopInd) / & + (0.5*DepthSnowSoilLayer(LoopInd)*DepthSnowSoilLayer(LoopInd)*HeatCapacSoilSnow(LoopInd)) + endif + elseif ( LoopInd < NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = - ThermConductSoilSnow(LoopInd ) * DepthSnowSoilInv(LoopInd ) / HeatCapacPerArea(LoopInd) + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3 (LoopInd)) + elseif ( LoopInd == NumSoilLayer ) then + MatLeft1(LoopInd) = - ThermConductSoilSnow(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / HeatCapacPerArea(LoopInd) + MatLeft3(LoopInd) = 0.0 + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + endif + MatRight(LoopInd) = EnergyExcess(LoopInd) / (-HeatCapacPerArea(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSnowSoilInv) + deallocate(HeatCapacPerArea) + deallocate(TempGradDepth ) + deallocate(EnergyExcess ) + + end associate + + end subroutine SoilSnowThermalDiffusion + +end module SoilSnowThermalDiffusionMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowWaterPhaseChangeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowWaterPhaseChangeMod.F90 new file mode 100644 index 0000000000..fb8a202bc0 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilSnowWaterPhaseChangeMod.F90 @@ -0,0 +1,258 @@ +module SoilSnowWaterPhaseChangeMod + +!!! Compute the phase change (melting/freezing) of snow water and soil water + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilWaterSupercoolKoren99Mod, only : SoilWaterSupercoolKoren99 + use SoilWaterSupercoolNiu06Mod, only : SoilWaterSupercoolNiu06 + + implicit none + +contains + + subroutine SoilSnowWaterPhaseChange(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: PHASECHANGE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! do loop index + real(kind=kind_noahmp) :: EnergyResLeft ! energy residual or loss after melting/freezing + real(kind=kind_noahmp) :: SnowWaterPrev ! old/previous snow water equivalent [kg/m2] + real(kind=kind_noahmp) :: SnowWaterRatio ! ratio of previous vs updated snow water equivalent + real(kind=kind_noahmp) :: HeatLhTotPhsChg ! total latent heat of phase change + real(kind=kind_noahmp), allocatable, dimension(:) :: EnergyRes ! energy residual [w/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: WaterPhaseChg ! melting or freezing water [kg/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatTotInit ! initial total water (ice + liq) mass + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceInit ! initial ice content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqInit ! initial liquid content + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatIceTmp ! soil/snow ice mass [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: MassWatLiqTmp ! soil/snow liquid water mass [mm] + +! -------------------------------------------------------------------- + associate( & + OptSoilSupercoolWater => noahmp%config%nmlist%OptSoilSupercoolWater ,& ! in, options for soil supercooled liquid water + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& ! in, maximum number of snow layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + PhaseChgFacSoilSnow => noahmp%energy%state%PhaseChgFacSoilSnow ,& ! in, energy factor for soil & snow phase change + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! inout, snow and soil layer temperature [K] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + SnowIce => noahmp%water%state%SnowIce ,& ! inout, snow layer ice [mm] + SnowLiqWater => noahmp%water%state%SnowLiqWater ,& ! inout, snow layer liquid water [mm] + SnowDepth => noahmp%water%state%SnowDepth ,& ! inout, snow depth [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + IndexPhaseChange => noahmp%water%state%IndexPhaseChange ,& ! out, phase change index [0-none;1-melt;2-refreeze] + SoilSupercoolWater => noahmp%water%state%SoilSupercoolWater ,& ! out, supercooled water in soil [kg/m2] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt ,& ! out, surface ponding [mm] from melt when thin snow w/o layer + MeltGroundSnow => noahmp%water%flux%MeltGroundSnow & ! out, ground snowmelt rate [mm/s] + ) +! ---------------------------------------------------------------------- + + !--- Initialization + if (.not. allocated(EnergyRes) ) allocate(EnergyRes (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(WaterPhaseChg) ) allocate(WaterPhaseChg (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatTotInit)) allocate(MassWatTotInit(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceInit)) allocate(MassWatIceInit(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqInit)) allocate(MassWatLiqInit(-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatIceTmp) ) allocate(MassWatIceTmp (-NumSnowLayerMax+1:NumSoilLayer)) + if (.not. allocated(MassWatLiqTmp) ) allocate(MassWatLiqTmp (-NumSnowLayerMax+1:NumSoilLayer)) + EnergyRes = 0.0 + WaterPhaseChg = 0.0 + MassWatTotInit = 0.0 + MassWatIceInit = 0.0 + MassWatLiqInit = 0.0 + MassWatIceTmp = 0.0 + MassWatLiqTmp = 0.0 + MeltGroundSnow = 0.0 + PondSfcThinSnwMelt = 0.0 + HeatLhTotPhsChg = 0.0 + + ! supercooled water content + do LoopInd = -NumSnowLayerMax+1, NumSoilLayer + SoilSupercoolWater(LoopInd) = 0.0 + enddo + + ! snow layer water mass + do LoopInd = NumSnowLayerNeg+1, 0 + MassWatIceTmp(LoopInd) = SnowIce(LoopInd) + MassWatLiqTmp(LoopInd) = SnowLiqWater(LoopInd) + enddo + + ! soil layer water mass + do LoopInd = 1, NumSoilLayer + MassWatLiqTmp(LoopInd) = SoilLiqWater(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + MassWatIceTmp(LoopInd) = (SoilMoisture(LoopInd) - SoilLiqWater(LoopInd)) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + enddo + + ! other required variables + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + IndexPhaseChange(LoopInd) = 0 + EnergyRes(LoopInd) = 0.0 + WaterPhaseChg(LoopInd) = 0.0 + MassWatIceInit(LoopInd) = MassWatIceTmp(LoopInd) + MassWatLiqInit(LoopInd) = MassWatLiqTmp(LoopInd) + MassWatTotInit(LoopInd) = MassWatIceTmp(LoopInd) + MassWatLiqTmp(LoopInd) + enddo + + !--- compute soil supercool water content + if ( SurfaceType == 1 ) then ! land points + do LoopInd = 1, NumSoilLayer + if ( OptSoilSupercoolWater == 1 ) then + if ( TemperatureSoilSnow(LoopInd) < ConstFreezePoint ) then + call SoilWaterSupercoolNiu06(noahmp, LoopInd, SoilSupercoolWater(LoopInd),TemperatureSoilSnow(LoopInd)) + SoilSupercoolWater(LoopInd) = SoilSupercoolWater(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + endif + endif + if ( OptSoilSupercoolWater == 2 ) then + if ( TemperatureSoilSnow(LoopInd) < ConstFreezePoint ) then + call SoilWaterSupercoolKoren99(noahmp, LoopInd, SoilSupercoolWater(LoopInd), & + TemperatureSoilSnow(LoopInd), SoilMoisture(LoopInd), SoilLiqWater(LoopInd)) + SoilSupercoolWater(LoopInd) = SoilSupercoolWater(LoopInd) * ThicknessSnowSoilLayer(LoopInd) * 1000.0 + endif + endif + enddo + endif + + !--- determine melting or freezing state + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( (MassWatIceTmp(LoopInd) > 0.0) .and. (TemperatureSoilSnow(LoopInd) >= ConstFreezePoint) ) then + IndexPhaseChange(LoopInd) = 1 ! melting + endif + if ( (MassWatLiqTmp(LoopInd) > SoilSupercoolWater(LoopInd)) .and. & + (TemperatureSoilSnow(LoopInd) < ConstFreezePoint) ) then + IndexPhaseChange(LoopInd) = 2 ! freezing + endif + ! If snow exists, but its thickness is not enough to create a layer + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (LoopInd == 1) ) then + if ( TemperatureSoilSnow(LoopInd) >= ConstFreezePoint ) then + IndexPhaseChange(LoopInd) = 1 + endif + endif + enddo + + !--- Calculate the energy surplus and loss for melting and freezing + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( IndexPhaseChange(LoopInd) > 0 ) then + EnergyRes(LoopInd) = (TemperatureSoilSnow(LoopInd)-ConstFreezePoint) / PhaseChgFacSoilSnow(LoopInd) + TemperatureSoilSnow(LoopInd) = ConstFreezePoint + endif + if ( (IndexPhaseChange(LoopInd) == 1) .and. (EnergyRes(LoopInd) < 0.0) ) then + EnergyRes(LoopInd) = 0.0 + IndexPhaseChange(LoopInd) = 0 + endif + if ( (IndexPhaseChange(LoopInd) == 2) .and. (EnergyRes(LoopInd) > 0.0) ) then + EnergyRes(LoopInd) = 0.0 + IndexPhaseChange(LoopInd) = 0 + endif + WaterPhaseChg(LoopInd) = EnergyRes(LoopInd) * MainTimeStep / ConstLatHeatFusion + enddo + + !--- The rate of melting for snow without a layer, needs more work. + if ( (NumSnowLayerNeg == 0) .and. (SnowWaterEquiv > 0.0) .and. (WaterPhaseChg(1) > 0.0) ) then + SnowWaterPrev = SnowWaterEquiv + SnowWaterEquiv = max(0.0, SnowWaterPrev-WaterPhaseChg(1)) + SnowWaterRatio = SnowWaterEquiv / SnowWaterPrev + SnowDepth = max(0.0, SnowWaterRatio*SnowDepth ) + SnowDepth = min(max(SnowDepth,SnowWaterEquiv/500.0), SnowWaterEquiv/50.0) ! limit adjustment to a reasonable density + EnergyResLeft = EnergyRes(1) - ConstLatHeatFusion * (SnowWaterPrev - SnowWaterEquiv) / MainTimeStep + if ( EnergyResLeft > 0.0 ) then + WaterPhaseChg(1) = EnergyResLeft * MainTimeStep / ConstLatHeatFusion + EnergyRes(1) = EnergyResLeft + else + WaterPhaseChg(1) = 0.0 + EnergyRes(1) = 0.0 + endif + MeltGroundSnow = max(0.0, (SnowWaterPrev-SnowWaterEquiv)) / MainTimeStep + HeatLhTotPhsChg = ConstLatHeatFusion * MeltGroundSnow + PondSfcThinSnwMelt = SnowWaterPrev - SnowWaterEquiv + endif + + ! The rate of melting and freezing for multi-layer snow and soil + do LoopInd = NumSnowLayerNeg+1, NumSoilLayer + if ( (IndexPhaseChange(LoopInd) > 0) .and. (abs(EnergyRes(LoopInd)) > 0.0) ) then + EnergyResLeft = 0.0 + if ( WaterPhaseChg(LoopInd) > 0.0 ) then + MassWatIceTmp(LoopInd) = max(0.0, MassWatIceInit(LoopInd)-WaterPhaseChg(LoopInd)) + EnergyResLeft = EnergyRes(LoopInd) - ConstLatHeatFusion * & + (MassWatIceInit(LoopInd) - MassWatIceTmp(LoopInd)) / MainTimeStep + elseif ( WaterPhaseChg(LoopInd) < 0.0 ) then + if ( LoopInd <= 0 ) then ! snow layer + MassWatIceTmp(LoopInd) = min(MassWatTotInit(LoopInd), MassWatIceInit(LoopInd)-WaterPhaseChg(LoopInd)) + else ! soil layer + if ( MassWatTotInit(LoopInd) < SoilSupercoolWater(LoopInd) ) then + MassWatIceTmp(LoopInd) = 0.0 + else + MassWatIceTmp(LoopInd) = min(MassWatTotInit(LoopInd)-SoilSupercoolWater(LoopInd), & + MassWatIceInit(LoopInd)-WaterPhaseChg(LoopInd)) + MassWatIceTmp(LoopInd) = max(MassWatIceTmp(LoopInd), 0.0) + endif + endif + EnergyResLeft = EnergyRes(LoopInd) - ConstLatHeatFusion * (MassWatIceInit(LoopInd) - & + MassWatIceTmp(LoopInd)) / MainTimeStep + endif + MassWatLiqTmp(LoopInd) = max(0.0, MassWatTotInit(LoopInd)-MassWatIceTmp(LoopInd)) ! update liquid water mass + + ! update soil/snow temperature and energy surplus/loss + if ( abs(EnergyResLeft) > 0.0 ) then + TemperatureSoilSnow(LoopInd) = TemperatureSoilSnow(LoopInd) + PhaseChgFacSoilSnow(LoopInd) * EnergyResLeft + if ( LoopInd <= 0 ) then ! snow + if ( (MassWatLiqTmp(LoopInd)*MassWatIceTmp(LoopInd)) > 0.0 ) & + TemperatureSoilSnow(LoopInd) = ConstFreezePoint + if ( MassWatIceTmp(LoopInd) == 0.0 ) then ! BARLAGE + TemperatureSoilSnow(LoopInd) = ConstFreezePoint + EnergyRes(LoopInd+1) = EnergyRes(LoopInd+1) + EnergyResLeft + WaterPhaseChg(LoopInd+1) = EnergyRes(LoopInd+1) * MainTimeStep / ConstLatHeatFusion + endif + endif + endif + HeatLhTotPhsChg = HeatLhTotPhsChg + ConstLatHeatFusion * & + (MassWatIceInit(LoopInd) - MassWatIceTmp(LoopInd)) / MainTimeStep + ! snow melting rate + if ( LoopInd < 1 ) then + MeltGroundSnow = MeltGroundSnow + max(0.0, (MassWatIceInit(LoopInd)-MassWatIceTmp(LoopInd))) / MainTimeStep + endif + endif + enddo + + !--- update snow and soil ice and liquid content + do LoopInd = NumSnowLayerNeg+1, 0 ! snow + SnowLiqWater(LoopInd) = MassWatLiqTmp(LoopInd) + SnowIce(LoopInd) = MassWatIceTmp(LoopInd) + enddo + do LoopInd = 1, NumSoilLayer ! soil + SoilLiqWater(LoopInd) = MassWatLiqTmp(LoopInd) / (1000.0 * ThicknessSnowSoilLayer(LoopInd)) + SoilMoisture(LoopInd) = (MassWatLiqTmp(LoopInd)+MassWatIceTmp(LoopInd)) / (1000.0*ThicknessSnowSoilLayer(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(EnergyRes ) + deallocate(WaterPhaseChg ) + deallocate(MassWatTotInit) + deallocate(MassWatIceInit) + deallocate(MassWatLiqInit) + deallocate(MassWatIceTmp ) + deallocate(MassWatLiqTmp ) + + end associate + + end subroutine SoilSnowWaterPhaseChange + +end module SoilSnowWaterPhaseChangeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilThermalPropertyMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilThermalPropertyMod.F90 new file mode 100644 index 0000000000..dd38333c01 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilThermalPropertyMod.F90 @@ -0,0 +1,112 @@ +module SoilThermalPropertyMod + +!!! Compute soil thermal conductivity based on Peters-Lidard et al. (1998) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilThermalProperty(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: TDFCND +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! If the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: KerstenFac ! Kersten number + real(kind=kind_noahmp) :: SoilGamFac ! temporary soil GAMMD factor + real(kind=kind_noahmp) :: ThermConductSoilDry ! thermal conductivity for dry soil + real(kind=kind_noahmp) :: ThermConductSoilSat ! thermal conductivity for saturated soil + real(kind=kind_noahmp) :: ThermConductSolid ! thermal conductivity for the solids + real(kind=kind_noahmp) :: SoilSatRatio ! saturation ratio + real(kind=kind_noahmp) :: SoilWatFracSat ! saturated soil water fraction + real(kind=kind_noahmp) :: SoilWatFrac ! soil water fraction + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceTmp ! temporal soil ice + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilHeatCapacity => noahmp%energy%param%SoilHeatCapacity ,& ! in, soil volumetric specific heat [J/m3/K] + SoilQuartzFrac => noahmp%energy%param%SoilQuartzFrac ,& ! in, soil quartz content + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + HeatCapacVolSoil => noahmp%energy%state%HeatCapacVolSoil ,& ! out, soil layer volumetric specific heat [J/m3/K] + ThermConductSoil => noahmp%energy%state%ThermConductSoil & ! out, soil layer thermal conductivity [W/m/K] + ) +! ---------------------------------------------------------------------- + + ! initiazliation + if (.not. allocated(SoilIceTmp)) allocate(SoilIceTmp(1:NumSoilLayer)) + SoilIceTmp(:) = 0.0 + + do LoopInd = 1, NumSoilLayer + + ! ==== soil heat capacity + SoilIceTmp(LoopInd) = SoilMoisture(LoopInd) - SoilLiqWater(LoopInd) + HeatCapacVolSoil(LoopInd) = SoilLiqWater(LoopInd) * ConstHeatCapacWater + & + (1.0 - SoilMoistureSat(LoopInd)) * SoilHeatCapacity + & + (SoilMoistureSat(LoopInd) - SoilMoisture(LoopInd)) * ConstHeatCapacAir + & + SoilIceTmp(LoopInd) * ConstHeatCapacIce + + ! ==== soil thermal conductivity + SoilSatRatio = SoilMoisture(LoopInd) / SoilMoistureSat(LoopInd) ! SATURATION RATIO + + ! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + ThermConductSolid = (ConstThermConductQuartz ** SoilQuartzFrac(LoopInd)) * & + (ConstThermConductSoilOth ** (1.0 - SoilQuartzFrac(LoopInd))) + + ! UNFROZEN VOLUME FOR SATURATION (POROSITY*SoilWatFrac) + SoilWatFrac = 1.0 ! Prevent divide by zero (suggested by D. Mocko) + if ( SoilMoisture(LoopInd) > 0.0 ) SoilWatFrac = SoilLiqWater(LoopInd) / SoilMoisture(LoopInd) + SoilWatFracSat = SoilWatFrac * SoilMoistureSat(LoopInd) + + ! SATURATED THERMAL CONDUCTIVITY + ThermConductSoilSat = ThermConductSolid ** (1.0-SoilMoistureSat(LoopInd)) * & + ConstThermConductIce ** (SoilMoistureSat(LoopInd)-SoilWatFracSat) * & + ConstThermConductWater ** (SoilWatFracSat) + + ! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + SoilGamFac = (1.0 - SoilMoistureSat(LoopInd)) * 2700.0 + ThermConductSoilDry = (0.135 * SoilGamFac + 64.7) / (2700.0 - 0.947 * SoilGamFac) + + ! THE KERSTEN NUMBER KerstenFac + if ( (SoilLiqWater(LoopInd)+0.0005) < SoilMoisture(LoopInd) ) then ! FROZEN + KerstenFac = SoilSatRatio + else ! UNFROZEN + ! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT + ! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) + ! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + if ( SoilSatRatio > 0.1 ) then + KerstenFac = log10(SoilSatRatio) + 1.0 + else + KerstenFac = 0.0 + endif + endif + + ! THERMAL CONDUCTIVITY + ThermConductSoil(LoopInd) = KerstenFac*(ThermConductSoilSat-ThermConductSoilDry) + ThermConductSoilDry + + enddo ! LoopInd + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilIceTmp) + + end associate + + end subroutine SoilThermalProperty + +end module SoilThermalPropertyMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterDiffusionRichardsMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterDiffusionRichardsMod.F90 new file mode 100644 index 0000000000..ebeaf64bf6 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterDiffusionRichardsMod.F90 @@ -0,0 +1,180 @@ +module SoilWaterDiffusionRichardsMod + +!!! Solve Richards equation for soil water movement/diffusion +!!! Compute the right hand side of the time tendency term of the soil +!!! water diffusion equation. also to compute (prepare) the matrix +!!! coefficients for the tri-diagonal matrix of the implicit time scheme. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod + + implicit none + +contains + + subroutine SoilWaterDiffusionRichards(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SRT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft1 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft2 ! left-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:), intent(inout) :: MatLeft3 ! left-hand side term of the matrix + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: DepthSnowSoilTmp ! temporary snow/soil layer depth [m] + real(kind=kind_noahmp) :: SoilMoistTmpToWT ! temporary soil moisture between bottom of the soil and water table + real(kind=kind_noahmp) :: SoilMoistBotTmp ! temporary soil moisture below bottom to calculate flux + real(kind=kind_noahmp), allocatable, dimension(:) :: DepthSnowSoilInv ! inverse of snow/soil layer depth [1/m] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilThickTmp ! temporary soil thickness + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWaterGrad ! temporary soil moisture vertical gradient + real(kind=kind_noahmp), allocatable, dimension(:) :: WaterExcess ! temporary excess water flux + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureTmp ! temporary soil moisture + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + OptSoilPermeabilityFrozen => noahmp%config%nmlist%OptSoilPermeabilityFrozen ,& ! in, options for frozen soil permeability + OptRunoffSubsurface => noahmp%config%nmlist%OptRunoffSubsurface ,& ! in, options for drainage and subsurface runoff + SoilDrainSlope => noahmp%water%param%SoilDrainSlope ,& ! in, slope index for soil drainage + InfilRateSfc => noahmp%water%flux%InfilRateSfc ,& ! in, infiltration rate at surface [m/s] + EvapSoilSfcLiqMean => noahmp%water%flux%EvapSoilSfcLiqMean ,& ! in, mean evaporation from soil surface [m/s] + TranspWatLossSoilMean => noahmp%water%flux%TranspWatLossSoilMean ,& ! in, mean transpiration water loss from soil layers [m/s] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! in, water table depth [m] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! in, fraction of imperviousness due to frozen soil + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! in, maximum soil imperviousness fraction + SoilIceMax => noahmp%water%state%SoilIceMax ,& ! in, maximum soil ice content [m3/m3] + SoilMoistureToWT => noahmp%water%state%SoilMoistureToWT ,& ! in, soil moisture between bottom of the soil and the water table + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! out, soil hydraulic conductivity [m/s] + SoilWatDiffusivity => noahmp%water%state%SoilWatDiffusivity ,& ! out, soil water diffusivity [m2/s] + DrainSoilBot => noahmp%water%flux%DrainSoilBot & ! out, soil bottom drainage [m/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DepthSnowSoilInv)) allocate(DepthSnowSoilInv(1:NumSoilLayer)) + if (.not. allocated(SoilThickTmp) ) allocate(SoilThickTmp (1:NumSoilLayer)) + if (.not. allocated(SoilWaterGrad) ) allocate(SoilWaterGrad (1:NumSoilLayer)) + if (.not. allocated(WaterExcess) ) allocate(WaterExcess (1:NumSoilLayer)) + if (.not. allocated(SoilMoistureTmp) ) allocate(SoilMoistureTmp (1:NumSoilLayer)) + MatRight(:) = 0.0 + MatLeft1(:) = 0.0 + MatLeft2(:) = 0.0 + MatLeft3(:) = 0.0 + DepthSnowSoilInv(:) = 0.0 + SoilThickTmp(:) = 0.0 + SoilWaterGrad(:) = 0.0 + WaterExcess(:) = 0.0 + SoilMoistureTmp(:) = 0.0 + + ! compute soil hydraulic conductivity and diffusivity + if ( OptSoilPermeabilityFrozen == 1 ) then + do LoopInd = 1, NumSoilLayer + call SoilDiffusivityConductivityOpt1(noahmp,SoilWatDiffusivity(LoopInd),SoilWatConductivity(LoopInd),& + SoilMoisture(LoopInd),SoilImpervFrac(LoopInd),LoopInd) + SoilMoistureTmp(LoopInd) = SoilMoisture(LoopInd) + enddo + if ( OptRunoffSubsurface == 5 ) SoilMoistTmpToWT = SoilMoistureToWT + endif + + if ( OptSoilPermeabilityFrozen == 2 ) then + do LoopInd = 1, NumSoilLayer + call SoilDiffusivityConductivityOpt2(noahmp,SoilWatDiffusivity(LoopInd),SoilWatConductivity(LoopInd),& + SoilLiqWater(LoopInd),SoilIceMax,LoopInd) + SoilMoistureTmp(LoopInd) = SoilLiqWater(LoopInd) + enddo + if ( OptRunoffSubsurface == 5 ) & + SoilMoistTmpToWT = SoilMoistureToWT * SoilLiqWater(NumSoilLayer) / SoilMoisture(NumSoilLayer) !same liquid fraction as in the bottom layer + endif + + ! compute gradient and flux of soil water diffusion terms + do LoopInd = 1, NumSoilLayer + if ( LoopInd == 1 ) then + SoilThickTmp(LoopInd) = - DepthSoilLayer(LoopInd) + DepthSnowSoilTmp = - DepthSoilLayer(LoopInd+1) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + SoilWaterGrad(LoopInd) = 2.0 * (SoilMoistureTmp(LoopInd)-SoilMoistureTmp(LoopInd+1)) / DepthSnowSoilTmp + WaterExcess(LoopInd) = SoilWatDiffusivity(LoopInd)*SoilWaterGrad(LoopInd) + SoilWatConductivity(LoopInd) - & + InfilRateSfc + TranspWatLossSoilMean(LoopInd) + EvapSoilSfcLiqMean + else if ( LoopInd < NumSoilLayer ) then + SoilThickTmp(LoopInd) = (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + DepthSnowSoilTmp = (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd+1)) + DepthSnowSoilInv(LoopInd) = 2.0 / DepthSnowSoilTmp + SoilWaterGrad(LoopInd) = 2.0 * (SoilMoistureTmp(LoopInd) - SoilMoistureTmp(LoopInd+1)) / DepthSnowSoilTmp + WaterExcess(LoopInd) = SoilWatDiffusivity(LoopInd)*SoilWaterGrad(LoopInd) + SoilWatConductivity(LoopInd) - & + SoilWatDiffusivity(LoopInd-1)*SoilWaterGrad(LoopInd-1) - SoilWatConductivity(LoopInd-1) + & + TranspWatLossSoilMean(LoopInd) + else + SoilThickTmp(LoopInd) = (DepthSoilLayer(LoopInd-1) - DepthSoilLayer(LoopInd)) + if ( (OptRunoffSubsurface == 1) .or. (OptRunoffSubsurface == 2) ) then + DrainSoilBot = 0.0 + endif + if ( (OptRunoffSubsurface == 3) .or. (OptRunoffSubsurface == 6) .or. & + (OptRunoffSubsurface == 7) .or. (OptRunoffSubsurface == 8) ) then + DrainSoilBot = SoilDrainSlope * SoilWatConductivity(LoopInd) + endif + if ( OptRunoffSubsurface == 4 ) then + DrainSoilBot = (1.0 - SoilImpervFracMax) * SoilWatConductivity(LoopInd) + endif + if ( OptRunoffSubsurface == 5 ) then ! gmm new m-m&f water table dynamics formulation + DepthSnowSoilTmp = 2.0 * SoilThickTmp(LoopInd) + if ( WaterTableDepth < (DepthSoilLayer(NumSoilLayer)-SoilThickTmp(NumSoilLayer)) ) then + ! gmm interpolate from below, midway to the water table, + ! to the middle of the auxiliary layer below the soil bottom + SoilMoistBotTmp = SoilMoistureTmp(LoopInd) - (SoilMoistureTmp(LoopInd)-SoilMoistTmpToWT) * & + SoilThickTmp(LoopInd)*2.0 / (SoilThickTmp(LoopInd)+DepthSoilLayer(LoopInd)-WaterTableDepth) + else + SoilMoistBotTmp = SoilMoistTmpToWT + endif + SoilWaterGrad(LoopInd) = 2.0 * (SoilMoistureTmp(LoopInd) - SoilMoistBotTmp) / DepthSnowSoilTmp + DrainSoilBot = SoilWatDiffusivity(LoopInd) * SoilWaterGrad(LoopInd) + SoilWatConductivity(LoopInd) + endif + WaterExcess(LoopInd) = -(SoilWatDiffusivity(LoopInd-1)*SoilWaterGrad(LoopInd-1)) - SoilWatConductivity(LoopInd-1) + & + TranspWatLossSoilMean(LoopInd) + DrainSoilBot + endif + enddo + + ! prepare the matrix coefficients for the tri-diagonal matrix + do LoopInd = 1, NumSoilLayer + if ( LoopInd == 1 ) then + MatLeft1(LoopInd) = 0.0 + MatLeft2(LoopInd) = SoilWatDiffusivity(LoopInd ) * DepthSnowSoilInv(LoopInd ) / SoilThickTmp(LoopInd) + MatLeft3(LoopInd) = - MatLeft2(LoopInd) + else if ( LoopInd < NumSoilLayer ) then + MatLeft1(LoopInd) = - SoilWatDiffusivity(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / SoilThickTmp(LoopInd) + MatLeft3(LoopInd) = - SoilWatDiffusivity(LoopInd ) * DepthSnowSoilInv(LoopInd ) / SoilThickTmp(LoopInd) + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + else + MatLeft1(LoopInd) = - SoilWatDiffusivity(LoopInd-1) * DepthSnowSoilInv(LoopInd-1) / SoilThickTmp(LoopInd) + MatLeft3(LoopInd) = 0.0 + MatLeft2(LoopInd) = - (MatLeft1(LoopInd) + MatLeft3(LoopInd)) + endif + MatRight(LoopInd) = WaterExcess(LoopInd) / (-SoilThickTmp(LoopInd)) + enddo + + ! deallocate local arrays to avoid memory leaks + deallocate(DepthSnowSoilInv) + deallocate(SoilThickTmp ) + deallocate(SoilWaterGrad ) + deallocate(WaterExcess ) + deallocate(SoilMoistureTmp ) + + end associate + + end subroutine SoilWaterDiffusionRichards + +end module SoilWaterDiffusionRichardsMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilGreenAmptMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilGreenAmptMod.F90 new file mode 100644 index 0000000000..c61793459f --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilGreenAmptMod.F90 @@ -0,0 +1,94 @@ +module SoilWaterInfilGreenAmptMod + +!!! Compute soil surface infiltration rate based on Green-Ampt equation +!!! We use its three parameter version of the smith-parlage equation, where gamma = 0, Eq 6.25 = Green-Ampt. +!!! Reference: Smith, R.E. (2002) Infiltration Theory for Hydrologic Applications, Water Resources Monograph + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine SoilWaterInfilGreenAmpt(noahmp, IndInfilMax, InfilSfcAcc, InfilSfcTmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: GREEN_AMPT_INFIL +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndInfilMax ! check for maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp), intent(inout) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), intent(out) :: InfilSfcTmp ! surface infiltration rate [m/s] + +! local variable + integer :: IndSoil ! soil layer index + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity[m/s] + real(kind=kind_noahmp) :: InfilFacTmp ! temporary infiltrability variable + +! -------------------------------------------------------------------- + associate( & + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat ,& ! in, saturated soil hydraulic conductivity [m/s] + InfilCapillaryDynVic => noahmp%water%param%InfilCapillaryDynVic & ! in, DVIC Mean Capillary Drive [m] for infiltration models + ) +! ---------------------------------------------------------------------- + + IndSoil = 1 + if ( IndInfilMax == 1 ) then + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoistureWilt(IndSoil), 0.0, IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * (SoilMoistureSat(IndSoil) - SoilMoistureWilt(IndSoil)) * & + (-1.0) * DepthSoilLayer(IndSoil) + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + & + ((InfilFacTmp/1.0e-05) * (SoilWatConductivitySat(IndSoil) - SoilWatConductivity)) + + !maximum infiltration rate at surface + if ( InfilSfcTmp < 0.0 ) InfilSfcTmp = SoilWatConductivity + + else + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture(IndSoil), SoilIce(IndSoil), IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * max(0.0, (SoilMoistureSat(IndSoil) - SoilMoisture(IndSoil))) * & + (-1.0) * DepthSoilLayer(IndSoil) + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + & + ((InfilFacTmp/InfilSfcAcc) * (SoilWatConductivitySat(IndSoil) - SoilWatConductivity)) + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + ! accumulated infiltration function + InfilSfcAcc = InfilSfcAcc + InfilSfcTmp + + endif + + end associate + + end subroutine SoilWaterInfilGreenAmpt + +end module SoilWaterInfilGreenAmptMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilPhilipMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilPhilipMod.F90 new file mode 100644 index 0000000000..9008f1caa2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilPhilipMod.F90 @@ -0,0 +1,104 @@ +module SoilWaterInfilPhilipMod + +!!! Compute soil surface infiltration rate based on Philip's two parameter equation +!!! Reference: Valiantzas (2010): New linearized two-parameter infiltration equation +!!! for direct determination of conductivity and sorptivity, J. Hydrology. + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine SoilWaterInfilPhilip(noahmp, TimeStep, IndInfilMax, InfilSfcAcc, InfilSfcTmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: PHILIP_INFIL +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndInfilMax ! check for maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp), intent(in) :: TimeStep ! timestep (may not be the same as model timestep) + real(kind=kind_noahmp), intent(inout) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), intent(out) :: InfilSfcTmp ! surface infiltration rate [m/s] + +! local variable + integer :: IndSoil ! soil layer index + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: SoilSorptivity ! sorptivity [m s^-1/2] + real(kind=kind_noahmp) :: SoilWatConductTmp ! intial hydraulic conductivity [m/s] + +! -------------------------------------------------------------------- + associate( & + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilWatDiffusivitySat => noahmp%water%param%SoilWatDiffusivitySat ,& ! in, saturated soil hydraulic diffusivity [m2/s] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat & ! in, saturated soil hydraulic conductivity [m/s] + ) +! ---------------------------------------------------------------------- + + IndSoil = 1 + if ( IndInfilMax == 1) then + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoistureWilt(IndSoil), 0.0, IndSoil) + + ! Sorptivity based on Eq. 10b from Kutílek, Miroslav, and Jana Valentová (1986) + ! Sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SoilSorptivity = sqrt(2.0 * (SoilMoistureSat(IndSoil) - SoilMoistureWilt(IndSoil)) * & + (SoilWatDiffusivitySat(IndSoil) - SoilWatDiffusivity)) + + ! Parameter A in Eq. 9 of Valiantzas (2010) is given by + SoilWatConductTmp = min(SoilWatConductivity, (2.0/3.0)*SoilWatConductivitySat(IndSoil)) + SoilWatConductTmp = max(SoilWatConductTmp, (1.0/3.0)*SoilWatConductivitySat(IndSoil)) + + ! Maximun infiltration rate + InfilSfcTmp = (1.0/2.0) * SoilSorptivity * (TimeStep**(-1.0/2.0)) + SoilWatConductTmp + if ( InfilSfcTmp < 0.0) InfilSfcTmp = SoilWatConductivity + + else + + ! estimate initial soil hydraulic conductivty and diffusivity (Ki, D(theta) in the equation) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture(IndSoil), SoilIce(IndSoil), IndSoil) + + ! Sorptivity based on Eq. 10b from Kutílek, Miroslav, and Jana Valentová (1986) + ! Sorptivity approximations. Transport in Porous Media 1.1, 57-62. + SoilSorptivity = sqrt(2.0 * max(0.0, (SoilMoistureSat(IndSoil)-SoilMoisture(IndSoil))) * & + (SoilWatDiffusivitySat(IndSoil) - SoilWatDiffusivity)) + ! Parameter A in Eq. 9 of Valiantzas (2010) is given by + SoilWatConductTmp = min(SoilWatConductivity, (2.0/3.0)*SoilWatConductivitySat(IndSoil)) + SoilWatConductTmp = max(SoilWatConductTmp, (1.0/3.0)*SoilWatConductivitySat(IndSoil)) + + ! Maximun infiltration rate + InfilSfcTmp = (1.0/2.0) * SoilSorptivity * (TimeStep**(-1.0/2.0)) + SoilWatConductTmp + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + ! accumulated infiltration function + InfilSfcAcc = InfilSfcAcc + InfilSfcTmp + + endif + + end associate + + end subroutine SoilWaterInfilPhilip + +end module SoilWaterInfilPhilipMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilSmithParlangeMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilSmithParlangeMod.F90 new file mode 100644 index 0000000000..5d87dfe957 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterInfilSmithParlangeMod.F90 @@ -0,0 +1,108 @@ +module SoilWaterInfilSmithParlangeMod + +!!! Compute soil surface infiltration rate based on Smith-Parlange equation +!!! Reference: Smith, R.E. (2002), Infiltration Theory for Hydrologic Applications + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SoilHydraulicPropertyMod, only : SoilDiffusivityConductivityOpt2 + + implicit none + +contains + + subroutine SoilWaterInfilSmithParlange(noahmp, IndInfilMax, InfilSfcAcc, InfilSfcTmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: SMITH_PARLANGE_INFIL +! Original code: Prasanth Valayamkunnath +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variabls + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in) :: IndInfilMax ! check for maximum infiltration at SoilMoistureWilt + real(kind=kind_noahmp), intent(inout) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), intent(out) :: InfilSfcTmp ! surface infiltration rate [m/s] + +! local variables + integer :: IndSoil ! soil layer index + real(kind=kind_noahmp) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp) :: SoilWatConductivity ! soil water conductivity [m/s] + real(kind=kind_noahmp) :: InfilFacTmp ! temporary infiltrability variable + real(kind=kind_noahmp) :: WeighFac ! smith-parlang weighing parameter + +! -------------------------------------------------------------------- + associate( & + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total soil moisture [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilWatConductivitySat => noahmp%water%param%SoilWatConductivitySat ,& ! in, saturated soil hydraulic conductivity [m/s] + InfilCapillaryDynVic => noahmp%water%param%InfilCapillaryDynVic & ! in, DVIC Mean Capillary Drive [m] for infiltration models + ) +! ---------------------------------------------------------------------- + + ! smith-parlang weighing parameter, Gamma + WeighFac = 0.82 + IndSoil = 1 + + ! check whether we are estimating infiltration for current SoilMoisture or SoilMoistureWilt + if ( IndInfilMax == 1 ) then ! not active for now as the maximum infiltration is estimated based on table values + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoistureWilt(IndSoil), 0.0, IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * (SoilMoistureSat(IndSoil) - SoilMoistureWilt(IndSoil)) * & + (-1.0) * DepthSoilLayer(IndSoil) + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + (WeighFac*(SoilWatConductivitySat(IndSoil)-SoilWatConductivity) / & + (exp(WeighFac*1.0e-05/InfilFacTmp) - 1.0)) + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + if ( InfilSfcTmp < 0.0 ) InfilSfcTmp = SoilWatConductivity + + else + + ! estimate initial soil hydraulic conductivty (Ki in the equation) (m/s) + call SoilDiffusivityConductivityOpt2(noahmp, SoilWatDiffusivity, SoilWatConductivity, & + SoilMoisture(IndSoil), SoilIce(IndSoil), IndSoil) + + ! Maximum infiltrability based on the Eq. 6.25. (m/s) + InfilFacTmp = InfilCapillaryDynVic * max(0.0, (SoilMoistureSat(IndSoil) - SoilMoisture(IndSoil))) * & + (-1.0) * DepthSoilLayer(IndSoil) + if ( InfilFacTmp == 0.0 ) then ! infiltration at surface == saturated hydraulic conductivity + InfilSfcTmp = SoilWatConductivity + else + InfilSfcTmp = SoilWatConductivitySat(IndSoil) + (WeighFac*(SoilWatConductivitySat(IndSoil)-SoilWatConductivity) / & + (exp(WeighFac*InfilSfcAcc/InfilFacTmp) - 1.0)) + endif + + ! infiltration rate at surface + if ( SoilWatConductivitySat(IndSoil) < SoilSfcInflowMean ) then + InfilSfcTmp = min(SoilSfcInflowMean, InfilSfcTmp) + else + InfilSfcTmp = SoilSfcInflowMean + endif + + ! accumulated infiltration function + InfilSfcAcc = InfilSfcAcc + InfilSfcTmp + + endif + + end associate + + end subroutine SoilWaterInfilSmithParlange + +end module SoilWaterInfilSmithParlangeMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterMainMod.F90 new file mode 100644 index 0000000000..a03a983b7a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterMainMod.F90 @@ -0,0 +1,270 @@ +module SoilWaterMainMod + +!!! Main soil water module including all soil water processes & update soil moisture +!!! surface runoff, infiltration, soil water diffusion, subsurface runoff, tile drainage + + use Machine + use NoahmpVarType + use ConstantDefineMod + use RunoffSurfaceTopModelGrdMod, only : RunoffSurfaceTopModelGrd + use RunoffSurfaceTopModelEquiMod, only : RunoffSurfaceTopModelEqui + use RunoffSurfaceFreeDrainMod, only : RunoffSurfaceFreeDrain + use RunoffSurfaceBatsMod, only : RunoffSurfaceBATS + use RunoffSurfaceTopModelMmfMod, only : RunoffSurfaceTopModelMMF + use RunoffSurfaceVicMod, only : RunoffSurfaceVIC + use RunoffSurfaceXinAnJiangMod, only : RunoffSurfaceXinAnJiang + use RunoffSurfaceDynamicVicMod, only : RunoffSurfaceDynamicVic + use RunoffSubSurfaceEquiWaterTableMod, only : RunoffSubSurfaceEquiWaterTable + use RunoffSubSurfaceGroundWaterMod, only : RunoffSubSurfaceGroundWater + use RunoffSubSurfaceDrainageMod, only : RunoffSubSurfaceDrainage + use RunoffSubSurfaceShallowMmfMod, only : RunoffSubSurfaceShallowWaterMMF + use SoilWaterDiffusionRichardsMod, only : SoilWaterDiffusionRichards + use SoilMoistureSolverMod, only : SoilMoistureSolver + use TileDrainageSimpleMod, only : TileDrainageSimple + use TileDrainageHooghoudtMod, only : TileDrainageHooghoudt + + implicit none + +contains + + subroutine SoilWaterMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SOILWATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: LoopInd1, LoopInd2 ! loop index + integer :: IndIter ! iteration index + integer :: NumIterSoilWat ! iteration times soil moisture + real(kind=kind_noahmp) :: TimeStepFine ! fine time step [s] + real(kind=kind_noahmp) :: SoilSatExcAcc ! accumulation of soil saturation excess [m] + real(kind=kind_noahmp) :: SoilWatConductAcc ! sum of SoilWatConductivity*ThicknessSnowSoilLayer + real(kind=kind_noahmp) :: WaterRemove ! water mass removal [mm] + real(kind=kind_noahmp) :: SoilWatRem ! temporary remaining soil water [mm] + real(kind=kind_noahmp) :: SoilWaterMin ! minimum soil water [mm] + real(kind=kind_noahmp) :: DrainSoilBotAcc ! accumulated drainage water [mm] at fine time step + real(kind=kind_noahmp) :: RunoffSurfaceAcc ! accumulated surface runoff [mm] at fine time step + real(kind=kind_noahmp) :: InfilSfcAcc ! accumulated infiltration rate [m/s] + real(kind=kind_noahmp), parameter :: SoilImpPara = 4.0 ! soil impervious fraction parameter + real(kind=kind_noahmp), allocatable, dimension(:) :: MatRight ! right-hand side term of the matrix + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft1 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft2 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: MatLeft3 ! left-hand side term + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqTmp ! temporary soil liquid water [mm] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil time step [s] + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + OptRunoffSurface => noahmp%config%nmlist%OptRunoffSurface ,& ! in, options for surface runoff + OptRunoffSubsurface => noahmp%config%nmlist%OptRunoffSubsurface ,& ! in, options for subsurface runoff + OptTileDrainage => noahmp%config%nmlist%OptTileDrainage ,& ! in, options for tile drainage + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + TileDrainFrac => noahmp%water%state%TileDrainFrac ,& ! in, tile drainage map (fraction) + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! in, mean water input on soil surface [m/s] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil water content [m3/m3] + RechargeGwDeepWT => noahmp%water%state%RechargeGwDeepWT ,& ! inout, recharge to or from the water table when deep [m] + DrainSoilBot => noahmp%water%flux%DrainSoilBot ,& ! out, soil bottom drainage [m/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [mm per soil timestep] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! out, subsurface runoff [mm per soil timestep] + InfilRateSfc => noahmp%water%flux%InfilRateSfc ,& ! out, infiltration rate at surface [m/s] + TileDrain => noahmp%water%flux%TileDrain ,& ! out, tile drainage [mm per soil timestep] + SoilImpervFracMax => noahmp%water%state%SoilImpervFracMax ,& ! out, maximum soil imperviousness fraction + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! out, soil hydraulic conductivity [m/s] + SoilEffPorosity => noahmp%water%state%SoilEffPorosity ,& ! out, soil effective porosity [m3/m3] + SoilImpervFrac => noahmp%water%state%SoilImpervFrac ,& ! out, impervious fraction due to frozen soil + SoilIceFrac => noahmp%water%state%SoilIceFrac ,& ! out, ice fraction in frozen soil + SoilSaturationExcess => noahmp%water%state%SoilSaturationExcess ,& ! out, saturation excess of the total soil [m] + SoilIceMax => noahmp%water%state%SoilIceMax ,& ! out, maximum soil ice content [m3/m3] + SoilLiqWaterMin => noahmp%water%state%SoilLiqWaterMin & ! out, minimum soil liquid water content [m3/m3] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(MatRight) ) allocate(MatRight (1:NumSoilLayer)) + if (.not. allocated(MatLeft1) ) allocate(MatLeft1 (1:NumSoilLayer)) + if (.not. allocated(MatLeft2) ) allocate(MatLeft2 (1:NumSoilLayer)) + if (.not. allocated(MatLeft3) ) allocate(MatLeft3 (1:NumSoilLayer)) + if (.not. allocated(SoilLiqTmp)) allocate(SoilLiqTmp(1:NumSoilLayer)) + MatRight = 0.0 + MatLeft1 = 0.0 + MatLeft2 = 0.0 + MatLeft3 = 0.0 + SoilLiqTmp = 0.0 + RunoffSurface = 0.0 + RunoffSubsurface = 0.0 + InfilRateSfc = 0.0 + SoilSatExcAcc = 0.0 + InfilSfcAcc = 1.0e-06 + + ! for the case when snowmelt water is too large + do LoopInd1 = 1, NumSoilLayer + SoilEffPorosity(LoopInd1) = max(1.0e-4, (SoilMoistureSat(LoopInd1) - SoilIce(LoopInd1))) + SoilSatExcAcc = SoilSatExcAcc + max(0.0, SoilLiqWater(LoopInd1) - SoilEffPorosity(LoopInd1)) * & + ThicknessSnowSoilLayer(LoopInd1) + SoilLiqWater(LoopInd1) = min(SoilEffPorosity(LoopInd1), SoilLiqWater(LoopInd1)) + enddo + + ! impermeable fraction due to frozen soil + do LoopInd1 = 1, NumSoilLayer + SoilIceFrac(LoopInd1) = min(1.0, SoilIce(LoopInd1) / SoilMoistureSat(LoopInd1)) + SoilImpervFrac(LoopInd1) = max(0.0, exp(-SoilImpPara*(1.0-SoilIceFrac(LoopInd1))) - exp(-SoilImpPara)) / & + (1.0 - exp(-SoilImpPara)) + enddo + + ! maximum soil ice content and minimum liquid water of all layers + SoilIceMax = 0.0 + SoilImpervFracMax = 0.0 + SoilLiqWaterMin = SoilMoistureSat(1) + do LoopInd1 = 1, NumSoilLayer + if ( SoilIce(LoopInd1) > SoilIceMax ) SoilIceMax = SoilIce(LoopInd1) + if ( SoilImpervFrac(LoopInd1) > SoilImpervFracMax ) SoilImpervFracMax = SoilImpervFrac(LoopInd1) + if ( SoilLiqWater(LoopInd1) < SoilLiqWaterMin ) SoilLiqWaterMin = SoilLiqWater(LoopInd1) + enddo + + ! subsurface runoff for runoff scheme option 2 + if ( OptRunoffSubsurface == 2 ) call RunoffSubSurfaceEquiWaterTable(noahmp) + + ! jref impermable surface at urban + if ( FlagUrban .eqv. .true. ) SoilImpervFrac(1) = 0.95 + + ! surface runoff and infiltration rate using different schemes + if ( OptRunoffSurface == 1 ) call RunoffSurfaceTopModelGrd(noahmp) + if ( OptRunoffSurface == 2 ) call RunoffSurfaceTopModelEqui(noahmp) + if ( OptRunoffSurface == 3 ) call RunoffSurfaceFreeDrain(noahmp,SoilTimeStep) + if ( OptRunoffSurface == 4 ) call RunoffSurfaceBATS(noahmp) + if ( OptRunoffSurface == 5 ) call RunoffSurfaceTopModelMMF(noahmp) + if ( OptRunoffSurface == 6 ) call RunoffSurfaceVIC(noahmp,SoilTimeStep) + if ( OptRunoffSurface == 7 ) call RunoffSurfaceXinAnJiang(noahmp,SoilTimeStep) + if ( OptRunoffSurface == 8 ) call RunoffSurfaceDynamicVic(noahmp,SoilTimeStep,InfilSfcAcc) + + ! determine iteration times to solve soil water diffusion and moisture + NumIterSoilWat = 3 + if ( (InfilRateSfc*SoilTimeStep) > (ThicknessSnowSoilLayer(1)*SoilMoistureSat(1)) ) then + NumIterSoilWat = NumIterSoilWat*2 + endif + TimeStepFine = SoilTimeStep / NumIterSoilWat + + ! solve soil moisture + InfilSfcAcc = 1.0e-06 + DrainSoilBotAcc = 0.0 + RunoffSurfaceAcc = 0.0 + + do IndIter = 1, NumIterSoilWat + if ( SoilSfcInflowMean > 0.0 ) then + if ( OptRunoffSurface == 3 ) call RunoffSurfaceFreeDrain(noahmp,TimeStepFine) + if ( OptRunoffSurface == 6 ) call RunoffSurfaceVIC(noahmp,TimeStepFine) + if ( OptRunoffSurface == 7 ) call RunoffSurfaceXinAnJiang(noahmp,TimeStepFine) + if ( OptRunoffSurface == 8 ) call RunoffSurfaceDynamicVic(noahmp,TimeStepFine,InfilSfcAcc) + endif + call SoilWaterDiffusionRichards(noahmp, MatLeft1, MatLeft2, MatLeft3, MatRight) + call SoilMoistureSolver(noahmp, TimeStepFine, MatLeft1, MatLeft2, MatLeft3, MatRight) + SoilSatExcAcc = SoilSatExcAcc + SoilSaturationExcess + DrainSoilBotAcc = DrainSoilBotAcc + DrainSoilBot + RunoffSurfaceAcc = RunoffSurfaceAcc + RunoffSurface + enddo + + DrainSoilBot = DrainSoilBotAcc / NumIterSoilWat + RunoffSurface = RunoffSurfaceAcc / NumIterSoilWat + RunoffSurface = RunoffSurface * 1000.0 + SoilSatExcAcc * 1000.0 / SoilTimeStep ! m/s -> mm/s + DrainSoilBot = DrainSoilBot * 1000.0 ! m/s -> mm/s + + ! compute tile drainage ! pvk + if ( (OptTileDrainage == 1) .and. (TileDrainFrac > 0.3) .and. (OptRunoffSurface == 3) ) then + call TileDrainageSimple(noahmp) ! simple tile drainage + endif + if ( (OptTileDrainage == 2) .and. (TileDrainFrac > 0.1) .and. (OptRunoffSurface == 3) ) then + call TileDrainageHooghoudt(noahmp) ! Hooghoudt tile drain + END IF + + ! removal of soil water due to subsurface runoff (option 2) + if ( OptRunoffSubsurface == 2 ) then + SoilWatConductAcc = 0.0 + do LoopInd1 = 1, NumSoilLayer + SoilWatConductAcc = SoilWatConductAcc + SoilWatConductivity(LoopInd1) * ThicknessSnowSoilLayer(LoopInd1) + enddo + do LoopInd1 = 1, NumSoilLayer + WaterRemove = RunoffSubsurface * SoilTimeStep * & + (SoilWatConductivity(LoopInd1)*ThicknessSnowSoilLayer(LoopInd1)) / SoilWatConductAcc + SoilLiqWater(LoopInd1) = SoilLiqWater(LoopInd1) - WaterRemove / (ThicknessSnowSoilLayer(LoopInd1)*1000.0) + enddo + endif + + ! Limit SoilLiqTmp to be greater than or equal to watmin. + ! Get water needed to bring SoilLiqTmp equal SoilWaterMin from lower layer. + if ( OptRunoffSubsurface /= 1 ) then + do LoopInd2 = 1, NumSoilLayer + SoilLiqTmp(LoopInd2) = SoilLiqWater(LoopInd2) * ThicknessSnowSoilLayer(LoopInd2) * 1000.0 + enddo + + SoilWaterMin = 0.01 ! mm + do LoopInd2 = 1, NumSoilLayer-1 + if ( SoilLiqTmp(LoopInd2) < 0.0 ) then + SoilWatRem = SoilWaterMin - SoilLiqTmp(LoopInd2) + else + SoilWatRem = 0.0 + endif + SoilLiqTmp(LoopInd2 ) = SoilLiqTmp(LoopInd2 ) + SoilWatRem + SoilLiqTmp(LoopInd2+1) = SoilLiqTmp(LoopInd2+1) - SoilWatRem + enddo + LoopInd2 = NumSoilLayer + if ( SoilLiqTmp(LoopInd2) < SoilWaterMin ) then + SoilWatRem = SoilWaterMin - SoilLiqTmp(LoopInd2) + else + SoilWatRem = 0.0 + endif + SoilLiqTmp(LoopInd2) = SoilLiqTmp(LoopInd2) + SoilWatRem + RunoffSubsurface = RunoffSubsurface - SoilWatRem/SoilTimeStep + + if ( OptRunoffSubsurface == 5 ) RechargeGwDeepWT = RechargeGwDeepWT - SoilWatRem * 1.0e-3 + + do LoopInd2 = 1, NumSoilLayer + SoilLiqWater(LoopInd2) = SoilLiqTmp(LoopInd2) / (ThicknessSnowSoilLayer(LoopInd2)*1000.0) + enddo + endif ! OptRunoffSubsurface /= 1 + + ! compute groundwater and subsurface runoff + if ( OptRunoffSubsurface == 1 ) call RunoffSubSurfaceGroundWater(noahmp) + + ! compute subsurface runoff based on drainage rate + if ( (OptRunoffSubsurface == 3) .or. (OptRunoffSubsurface == 4) .or. (OptRunoffSubsurface == 6) .or. & + (OptRunoffSubsurface == 7) .or. (OptRunoffSubsurface == 8) ) then + call RunoffSubSurfaceDrainage(noahmp) + endif + + ! update soil moisture + do LoopInd2 = 1, NumSoilLayer + SoilMoisture(LoopInd2) = SoilLiqWater(LoopInd2) + SoilIce(LoopInd2) + enddo + + ! compute subsurface runoff and shallow water table for MMF scheme + if ( OptRunoffSubsurface == 5 ) call RunoffSubSurfaceShallowWaterMMF(noahmp) + + ! accumulated water flux over soil timestep [mm] + RunoffSurface = RunoffSurface * SoilTimeStep + RunoffSubsurface = RunoffSubsurface * SoilTimeStep + TileDrain = TileDrain * SoilTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(MatRight ) + deallocate(MatLeft1 ) + deallocate(MatLeft2 ) + deallocate(MatLeft3 ) + deallocate(SoilLiqTmp) + + end associate + + end subroutine SoilWaterMain + +end module SoilWaterMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolKoren99Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolKoren99Mod.F90 new file mode 100644 index 0000000000..49f3dedbb2 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolKoren99Mod.F90 @@ -0,0 +1,127 @@ +module SoilWaterSupercoolKoren99Mod + +!!! Calculate amount of supercooled liquid soil water content if soil temperature < freezing point +!!! This uses Newton-type iteration to solve the nonlinear implicit equation +!!! Reference: Eqn.17 in Koren et al. 1999 JGR VOL 104(D16), 19569-19585 +!!! New version (June 2001): much faster and more accurate Newton iteration achieved by first +!!! taking log of Eqn above -- less than 4 (typically 1 or 2) iterations achieves convergence. +!!! Explicit 1-step solution option for special case of parameter CK=0, which reduces the +!!! original implicit equation to a simpler explicit form, known as "Flerchinger Eqn". Improved +!!! handling of solution in the limit of freezing point temperature. + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilWaterSupercoolKoren99(noahmp, IndSoil, SoilWatSupercool, & + SoilTemperature, SoilMoisture, SoilLiqWater) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: FRH2O +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in ) :: IndSoil ! soil layer index + real(kind=kind_noahmp), intent(in ) :: SoilLiqWater ! soil liquid water content [m3/m3] + real(kind=kind_noahmp), intent(in ) :: SoilMoisture ! total soil moisture content [m3/m3] + real(kind=kind_noahmp), intent(in ) :: SoilTemperature ! soil temperature [K] + real(kind=kind_noahmp), intent(out ) :: SoilWatSupercool ! soil supercooled liquid water content [m3/m3] + +! local variable + integer :: NumIter ! number of iteration + integer :: IndCnt ! counting index + real(kind=kind_noahmp) :: SoilExpB ! temporary soil B parameter + real(kind=kind_noahmp) :: Denom ! temporary denominator variable + real(kind=kind_noahmp) :: DF ! temporary nominator variable + real(kind=kind_noahmp) :: SoilIceChg ! soil ice content change + real(kind=kind_noahmp) :: FlerFac ! factor in Flerchinger solution + real(kind=kind_noahmp) :: SoilIce ! soil ice content + real(kind=kind_noahmp) :: SoilIceTmp ! temporary soil ice content + real(kind=kind_noahmp), parameter :: CK = 8.0 ! parameter + real(kind=kind_noahmp), parameter :: SoilExpBMax = 5.5 ! limit of B soil parameter + real(kind=kind_noahmp), parameter :: ErrorThr = 0.005 ! error threshold + +! -------------------------------------------------------------------- + associate( & + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat & ! in, saturated value of soil moisture [m3/m3] + ) +! ---------------------------------------------------------------------- + + ! limit on parameter B: B < 5.5 (use parameter SoilExpBMax) + ! simulations showed if B > 5.5 unfrozen water content is + ! non-realistically high at very low temperatures + SoilExpB = SoilExpCoeffB(IndSoil) + + ! initializing iterations counter and interative solution flag + if ( SoilExpCoeffB(IndSoil) > SoilExpBMax ) SoilExpB = SoilExpBMax + NumIter = 0 + + ! if soil temperature not largely below freezing point, SoilLiqWater = SoilMoisture + IndCnt = 0 + if ( SoilTemperature > (ConstFreezePoint-1.0e-3) ) then + SoilWatSupercool = SoilMoisture + else ! frozen soil case + + !--- Option 1: iterated solution in Koren et al. 1999 JGR Eqn.17 + ! initial guess for SoilIce (frozen content) + if ( CK /= 0.0 ) then + SoilIce = SoilMoisture - SoilLiqWater + if ( SoilIce > (SoilMoisture-0.02) ) SoilIce = SoilMoisture - 0.02 ! keep within bounds + ! start the iterations + if ( SoilIce < 0.0 ) SoilIce = 0.0 +1001 Continue + if ( .not. ((NumIter < 10) .and. (IndCnt == 0)) ) goto 1002 + NumIter = NumIter +1 + DF = alog((SoilMatPotentialSat(IndSoil)*ConstGravityAcc/ConstLatHeatFusion) * & + ((1.0 + CK*SoilIce)**2.0) * (SoilMoistureSat(IndSoil)/(SoilMoisture - SoilIce))**SoilExpB) - & + alog(-(SoilTemperature - ConstFreezePoint) / SoilTemperature) + Denom = 2.0 * CK / (1.0 + CK * SoilIce) + SoilExpB / (SoilMoisture - SoilIce) + SoilIceTmp = SoilIce - DF / Denom + ! bounds useful for mathematical solution + if ( SoilIceTmp > (SoilMoisture-0.02) ) SoilIceTmp = SoilMoisture - 0.02 + if ( SoilIceTmp < 0.0 ) SoilIceTmp = 0.0 + SoilIceChg = abs(SoilIceTmp - SoilIce) ! mathematical solution bounds applied + ! if more than 10 iterations, use explicit method (CK=0 approx.) + ! when SoilIceChg <= ErrorThr, no more interations required. + SoilIce = SoilIceTmp + if ( SoilIceChg <= ErrorThr ) then + IndCnt = IndCnt +1 + endif + ! end of iteration + ! bounds applied within do-block are valid for physical solution + goto 1001 +1002 continue + SoilWatSupercool = SoilMoisture - SoilIce + endif + !--- End Option 1 + + !--- Option 2: explicit solution for Flerchinger Eq. i.e., CK=0 + ! in Koren et al. 1999 JGR Eqn. 17 + ! apply physical bounds to Flerchinger solution + if ( IndCnt == 0 ) then + print*, 'Flerchinger used in NEW version. Iterations=', NumIter + FlerFac = (((ConstLatHeatFusion / (ConstGravityAcc * (-SoilMatPotentialSat(IndSoil)))) * & + ((SoilTemperature-ConstFreezePoint) / SoilTemperature))**(-1.0/SoilExpB)) * SoilMoistureSat(IndSoil) + if ( FlerFac < 0.02 ) FlerFac = 0.02 + SoilWatSupercool = min(FlerFac, SoilMoisture) + endif + !--- End Option 2 + + endif + + end associate + + end subroutine SoilWaterSupercoolKoren99 + +end module SoilWaterSupercoolKoren99Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolNiu06Mod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolNiu06Mod.F90 new file mode 100644 index 0000000000..770d979169 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterSupercoolNiu06Mod.F90 @@ -0,0 +1,48 @@ +module SoilWaterSupercoolNiu06Mod + +!!! Calculate amount of supercooled liquid soil water content if soil temperature < freezing point +!!! This solution does not use iteration (Niu and Yang, 2006 JHM). + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilWaterSupercoolNiu06(noahmp, IndSoil, SoilWatSupercool, SoilTemperature) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: embedded in PHASECHANGE +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type) , intent(inout) :: noahmp + integer , intent(in ) :: IndSoil ! soil layer index + real(kind=kind_noahmp), intent(in ) :: SoilTemperature ! soil temperature [K] + real(kind=kind_noahmp), intent(out ) :: SoilWatSupercool ! soil supercooled liquid water content [m3/m3] + +! local variable + real(kind=kind_noahmp) :: SoilWatPotFrz ! frozen water potential [mm] + +! ----------------------------------------------------------------------------- + associate( & + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat & ! in, saturated value of soil moisture [m3/m3] + ) +! ----------------------------------------------------------------------------- + + SoilWatPotFrz = ConstLatHeatFusion * (ConstFreezePoint - SoilTemperature) / (ConstGravityAcc * SoilTemperature) + SoilWatSupercool = SoilMoistureSat(IndSoil) * (SoilWatPotFrz / SoilMatPotentialSat(IndSoil))**(-1.0/SoilExpCoeffB(IndSoil)) + + end associate + + end subroutine SoilWaterSupercoolNiu06 + +end module SoilWaterSupercoolNiu06Mod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterTranspirationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterTranspirationMod.F90 new file mode 100644 index 0000000000..d5ef583af1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SoilWaterTranspirationMod.F90 @@ -0,0 +1,91 @@ +module SoilWaterTranspirationMod + +!!! compute soil water transpiration factor that will be used for +!!! stomata resistance and evapotranspiration calculations + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SoilWaterTranspiration(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variables + integer :: IndSoil ! loop index + real(kind=kind_noahmp) :: SoilWetFac ! temporary variable + real(kind=kind_noahmp) :: MinThr ! minimum threshold to prevent divided by zero + +! -------------------------------------------------------------------- + associate( & + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + OptSoilWaterTranspiration => noahmp%config%nmlist%OptSoilWaterTranspiration ,& ! in, option for soil moisture factor for stomatal resistance & ET + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + SoilMatPotentialWilt => noahmp%water%param%SoilMatPotentialWilt ,& ! in, soil metric potential for wilting point [m] + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilTranspFac => noahmp%water%state%SoilTranspFac ,& ! out, soil water transpiration factor (0 to 1) + SoilTranspFacAcc => noahmp%water%state%SoilTranspFacAcc ,& ! out, accumulated soil water transpiration factor (0 to 1) + SoilMatPotential => noahmp%water%state%SoilMatPotential & ! out, soil matrix potential [m] + ) +! ---------------------------------------------------------------------- + + ! soil moisture factor controlling stomatal resistance and evapotranspiration + MinThr = 1.0e-6 + SoilTranspFacAcc = 0.0 + + ! only for soil point + if ( SurfaceType ==1 ) then + do IndSoil = 1, NumSoilLayerRoot + if ( OptSoilWaterTranspiration == 1 ) then ! Noah + SoilWetFac = (SoilLiqWater(IndSoil) - SoilMoistureWilt(IndSoil)) / & + (SoilMoistureFieldCap(IndSoil) - SoilMoistureWilt(IndSoil)) + endif + if ( OptSoilWaterTranspiration == 2 ) then ! CLM + SoilMatPotential(IndSoil) = max(SoilMatPotentialWilt, -SoilMatPotentialSat(IndSoil) * & + (max(0.01,SoilLiqWater(IndSoil))/SoilMoistureSat(IndSoil)) ** & + (-SoilExpCoeffB(IndSoil))) + SoilWetFac = (1.0 - SoilMatPotential(IndSoil)/SoilMatPotentialWilt) / & + (1.0 + SoilMatPotentialSat(IndSoil)/SoilMatPotentialWilt) + endif + if ( OptSoilWaterTranspiration == 3 ) then ! SSiB + SoilMatPotential(IndSoil) = max(SoilMatPotentialWilt, -SoilMatPotentialSat(IndSoil) * & + (max(0.01,SoilLiqWater(IndSoil))/SoilMoistureSat(IndSoil)) ** & + (-SoilExpCoeffB(IndSoil))) + SoilWetFac = 1.0 - exp(-5.8*(log(SoilMatPotentialWilt/SoilMatPotential(IndSoil)))) + endif + SoilWetFac = min(1.0, max(0.0,SoilWetFac)) + + SoilTranspFac(IndSoil) = max(MinThr, ThicknessSnowSoilLayer(IndSoil) / & + (-DepthSoilLayer(NumSoilLayerRoot)) * SoilWetFac) + SoilTranspFacAcc = SoilTranspFacAcc + SoilTranspFac(IndSoil) + enddo + + SoilTranspFacAcc = max(MinThr, SoilTranspFacAcc) + SoilTranspFac(1:NumSoilLayerRoot) = SoilTranspFac(1:NumSoilLayerRoot) / SoilTranspFacAcc + endif + + end associate + + end subroutine SoilWaterTranspiration + +end module SoilWaterTranspirationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoGlacierMod.F90 new file mode 100644 index 0000000000..515a22357a --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoGlacierMod.F90 @@ -0,0 +1,79 @@ +module SurfaceAlbedoGlacierMod + +!!! Compute glacier surface albedo + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowAgingBatsMod, only : SnowAgingBats + use SnowAlbedoBatsMod, only : SnowAlbedoBats + use SnowAlbedoClassMod, only : SnowAlbedoClass + use GroundAlbedoGlacierMod, only : GroundAlbedoGlacier + + implicit none + +contains + + subroutine SurfaceAlbedoGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RADIATION_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! solar band index + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + OptSnowAlbedo => noahmp%config%nmlist%OptSnowAlbedo ,& ! in, options for ground snow surface albedo + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! out, ground albedo (diffuse: vis, nir) + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! out, snow albedo for diffuse(1=vis, 2=nir) + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! out, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif & ! out, surface albedo (diffuse) + ) +! ---------------------------------------------------------------------- + + ! initialization + do IndBand = 1, NumSwRadBand + AlbedoSfcDir (IndBand) = 0.0 + AlbedoSfcDif (IndBand) = 0.0 + AlbedoGrdDir (IndBand) = 0.0 + AlbedoGrdDif (IndBand) = 0.0 + AlbedoSnowDir(IndBand) = 0.0 + AlbedoSnowDif(IndBand) = 0.0 + enddo + + ! solar radiation process is only done if there is light + if ( CosSolarZenithAngle > 0 ) then + + ! snow aging + call SnowAgingBats(noahmp) + + ! snow albedo + if ( OptSnowAlbedo == 1 ) call SnowAlbedoBats(noahmp) + if ( OptSnowAlbedo == 2 ) call SnowAlbedoClass(noahmp) + + ! ground albedo + call GroundAlbedoGlacier(noahmp) + + ! surface albedo + AlbedoSfcDir = AlbedoGrdDir + AlbedoSfcDif = AlbedoGrdDif + + endif ! CosSolarZenithAngle > 0 + + end associate + + end subroutine SurfaceAlbedoGlacier + +end module SurfaceAlbedoGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoMod.F90 new file mode 100644 index 0000000000..d8e4bf109e --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceAlbedoMod.F90 @@ -0,0 +1,159 @@ +module SurfaceAlbedoMod + +!!! Compute total surface albedo and vegetation radiative fluxes +!!! per unit incoming direct and diffuse radiation and sunlit fraction of canopy + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowAgingBatsMod, only : SnowAgingBats + use SnowAlbedoBatsMod, only : SnowAlbedoBats + use SnowAlbedoClassMod, only : SnowAlbedoClass + use GroundAlbedoMod, only : GroundAlbedo + use CanopyRadiationTwoStreamMod, only : CanopyRadiationTwoStream + + implicit none + +contains + + subroutine SurfaceAlbedo(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ALBEDO +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! waveband indices + integer :: IndDif ! direct beam: IndDif=0; diffuse: IndDif=1 + real(kind=kind_noahmp) :: LeafWgt ! fraction of LeafAreaIndex+StemAreaIndex that is LeafAreaIndex + real(kind=kind_noahmp) :: StemWgt ! fraction of LeafAreaIndex+StemAreaIndex that is StemAreaIndex + real(kind=kind_noahmp) :: MinThr ! prevents overflow for division by zero + real(kind=kind_noahmp) :: LightExtDir ! optical depth direct beam per unit leaf + stem area + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + CosSolarZenithAngle => noahmp%config%domain%CosSolarZenithAngle ,& ! in, cosine solar zenith angle + OptSnowAlbedo => noahmp%config%nmlist%OptSnowAlbedo ,& ! in, options for ground snow surface albedo + ReflectanceLeaf => noahmp%energy%param%ReflectanceLeaf ,& ! in, leaf reflectance: 1=vis, 2=nir + ReflectanceStem => noahmp%energy%param%ReflectanceStem ,& ! in, stem reflectance: 1=vis, 2=nir + TransmittanceLeaf => noahmp%energy%param%TransmittanceLeaf ,& ! in, leaf transmittance: 1=vis, 2=nir + TransmittanceStem => noahmp%energy%param%TransmittanceStem ,& ! in, stem transmittance: 1=vis, 2=nir + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! out, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! out, ground albedo (diffuse: vis, nir) + AlbedoSnowDir => noahmp%energy%state%AlbedoSnowDir ,& ! out, snow albedo for direct(1=vis, 2=nir) + AlbedoSnowDif => noahmp%energy%state%AlbedoSnowDif ,& ! out, snow albedo for diffuse(1=vis, 2=nir) + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! out, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif ,& ! out, surface albedo (diffuse) + CanopySunlitFrac => noahmp%energy%state%CanopySunlitFrac ,& ! out, sunlit fraction of canopy + CanopyShadeFrac => noahmp%energy%state%CanopyShadeFrac ,& ! out, shaded fraction of canopy + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! out, sunlit leaf area + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! out, shaded leaf area + GapBtwCanopy => noahmp%energy%state%GapBtwCanopy ,& ! out, between canopy gap fraction for beam + GapInCanopy => noahmp%energy%state%GapInCanopy ,& ! out, within canopy gap fraction for beam + ReflectanceVeg => noahmp%energy%state%ReflectanceVeg ,& ! out, leaf/stem reflectance weighted by fraction LAI and SAI + TransmittanceVeg => noahmp%energy%state%TransmittanceVeg ,& ! out, leaf/stem transmittance weighted by fraction LAI and SAI + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! out, one-sided leaf+stem area index [m2/m2] + VegAreaProjDir => noahmp%energy%state%VegAreaProjDir ,& ! out, projected leaf+stem area in solar direction + RadSwAbsVegDir => noahmp%energy%flux%RadSwAbsVegDir ,& ! out, flux abs by veg (per unit direct flux) + RadSwAbsVegDif => noahmp%energy%flux%RadSwAbsVegDif ,& ! out, flux abs by veg (per unit diffuse flux) + RadSwDirTranGrdDir => noahmp%energy%flux%RadSwDirTranGrdDir ,& ! out, down direct flux below veg (per unit dir flux) + RadSwDifTranGrdDir => noahmp%energy%flux%RadSwDifTranGrdDir ,& ! out, down diffuse flux below veg (per unit dir flux) + RadSwDifTranGrdDif => noahmp%energy%flux%RadSwDifTranGrdDif ,& ! out, down diffuse flux below veg (per unit dif flux) + RadSwDirTranGrdDif => noahmp%energy%flux%RadSwDirTranGrdDif ,& ! out, down direct flux below veg per unit dif flux (= 0) + RadSwReflVegDir => noahmp%energy%flux%RadSwReflVegDir ,& ! out, flux reflected by veg layer (per unit direct flux) + RadSwReflVegDif => noahmp%energy%flux%RadSwReflVegDif ,& ! out, flux reflected by veg layer (per unit diffuse flux) + RadSwReflGrdDir => noahmp%energy%flux%RadSwReflGrdDir ,& ! out, flux reflected by ground (per unit direct flux) + RadSwReflGrdDif => noahmp%energy%flux%RadSwReflGrdDif & ! out, flux reflected by ground (per unit diffuse flux) + ) +! ---------------------------------------------------------------------- + + ! initialization + MinThr = 1.0e-06 + GapBtwCanopy = 0.0 + GapInCanopy = 0.0 + VegAreaProjDir = 0.0 + ReflectanceVeg = 0.0 + TransmittanceVeg = 0.0 + CanopySunlitFrac = 0.0 + do IndBand = 1, NumSwRadBand + AlbedoSfcDir (IndBand) = 0.0 + AlbedoSfcDif (IndBand) = 0.0 + AlbedoGrdDir (IndBand) = 0.0 + AlbedoGrdDif (IndBand) = 0.0 + AlbedoSnowDir (IndBand) = 0.0 + AlbedoSnowDif (IndBand) = 0.0 + RadSwAbsVegDir (IndBand) = 0.0 + RadSwAbsVegDif (IndBand) = 0.0 + RadSwDirTranGrdDir(IndBand) = 0.0 + RadSwDirTranGrdDif(IndBand) = 0.0 + RadSwDifTranGrdDir(IndBand) = 0.0 + RadSwDifTranGrdDif(IndBand) = 0.0 + RadSwReflVegDir (IndBand) = 0.0 + RadSwReflVegDif (IndBand) = 0.0 + RadSwReflGrdDir (IndBand) = 0.0 + RadSwReflGrdDif (IndBand) = 0.0 + enddo + VegAreaIndEff = LeafAreaIndEff + StemAreaIndEff + + ! solar radiation process is only done if there is light + if ( CosSolarZenithAngle > 0 ) then + + ! weight reflectance/transmittance by LeafAreaIndex and StemAreaIndex + LeafWgt = LeafAreaIndEff / max(VegAreaIndEff, MinThr) + StemWgt = StemAreaIndEff / max(VegAreaIndEff, MinThr) + do IndBand = 1, NumSwRadBand + ReflectanceVeg(IndBand) = max(ReflectanceLeaf(IndBand)*LeafWgt+ReflectanceStem(IndBand)*StemWgt, MinThr) + TransmittanceVeg(IndBand) = max(TransmittanceLeaf(IndBand)*LeafWgt+TransmittanceStem(IndBand)*StemWgt, MinThr) + enddo + + ! snow aging + call SnowAgingBats(noahmp) + + ! snow albedos + if ( OptSnowAlbedo == 1 ) call SnowAlbedoBats(noahmp) + if ( OptSnowAlbedo == 2 ) call SnowAlbedoClass(noahmp) + + ! ground surface albedo + call GroundAlbedo(noahmp) + + ! loop over shortwave bands to calculate surface albedos and solar + ! fluxes for unit incoming direct (IndDif=0) and diffuse flux (IndDif=1) + do IndBand = 1, NumSwRadBand + IndDif = 0 ! direct + call CanopyRadiationTwoStream(noahmp, IndBand, IndDif) + IndDif = 1 ! diffuse + call CanopyRadiationTwoStream(noahmp, IndBand, IndDif) + enddo + + ! sunlit fraction of canopy. set CanopySunlitFrac = 0 if CanopySunlitFrac < 0.01. + LightExtDir = VegAreaProjDir / CosSolarZenithAngle * sqrt(1.0-ReflectanceVeg(1)-TransmittanceVeg(1)) + CanopySunlitFrac = (1.0 - exp(-LightExtDir*VegAreaIndEff)) / max(LightExtDir*VegAreaIndEff, MinThr) + LightExtDir = CanopySunlitFrac + if ( LightExtDir < 0.01 ) then + LeafWgt = 0.0 + else + LeafWgt = LightExtDir + endif + CanopySunlitFrac = LeafWgt + + endif ! CosSolarZenithAngle > 0 + + ! shaded canopy fraction + CanopyShadeFrac = 1.0 - CanopySunlitFrac + LeafAreaIndSunlit = LeafAreaIndEff * CanopySunlitFrac + LeafAreaIndShade = LeafAreaIndEff * CanopyShadeFrac + + end associate + + end subroutine SurfaceAlbedo + +end module SurfaceAlbedoMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityGlacierMod.F90 new file mode 100644 index 0000000000..374f999503 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityGlacierMod.F90 @@ -0,0 +1,46 @@ +module SurfaceEmissivityGlacierMod + +!!! Compute glacier surface longwave emissivity + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceEmissivityGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY_GLACIER subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + EmissivitySnow => noahmp%energy%param%EmissivitySnow ,& ! in, snow emissivity + EmissivityIceSfc => noahmp%energy%param%EmissivityIceSfc ,& ! in, emissivity ice surface + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! out, ground emissivity + EmissivitySfc => noahmp%energy%state%EmissivitySfc & ! out, surface emissivity + ) +! ---------------------------------------------------------------------- + + ! ground emissivity + EmissivityGrd = EmissivityIceSfc * (1.0 - SnowCoverFrac) + EmissivitySnow * SnowCoverFrac + + ! surface emissivity + EmissivitySfc = EmissivityGrd + + end associate + + end subroutine SurfaceEmissivityGlacier + +end module SurfaceEmissivityGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityMod.F90 new file mode 100644 index 0000000000..1701a760bd --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEmissivityMod.F90 @@ -0,0 +1,61 @@ +module SurfaceEmissivityMod + +!!! Compute ground, vegetation, and total surface longwave emissivity + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceEmissivity(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: None (embedded in ENERGY subroutine) +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! -------------------------------------------------------------------- + associate( & + IndicatorIceSfc => noahmp%config%domain%IndicatorIceSfc ,& ! in, indicator for ice point: 1->seaice; -1->land ice; 0->soil + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + EmissivitySnow => noahmp%energy%param%EmissivitySnow ,& ! in, snow emissivity + EmissivitySoilLake => noahmp%energy%param%EmissivitySoilLake ,& ! in, emissivity soil surface + EmissivityIceSfc => noahmp%energy%param%EmissivityIceSfc ,& ! in, emissivity ice surface + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + StemAreaIndEff => noahmp%energy%state%StemAreaIndEff ,& ! in, stem area index, after burying by snow + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + EmissivityVeg => noahmp%energy%state%EmissivityVeg ,& ! out, vegetation emissivity + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! out, ground emissivity + EmissivitySfc => noahmp%energy%state%EmissivitySfc & ! out, surface emissivity + ) +! ---------------------------------------------------------------------- + + ! vegetation emissivity + EmissivityVeg = 1.0 - exp(-(LeafAreaIndEff + StemAreaIndEff) / 1.0) + + ! ground emissivity + if ( IndicatorIceSfc == 1 ) then + EmissivityGrd = EmissivityIceSfc * (1.0-SnowCoverFrac) + EmissivitySnow * SnowCoverFrac + else + EmissivityGrd = EmissivitySoilLake(SurfaceType) * (1.0-SnowCoverFrac) + EmissivitySnow * SnowCoverFrac + endif + + ! net surface emissivity + EmissivitySfc = VegFrac * (EmissivityGrd*(1-EmissivityVeg) + EmissivityVeg + & + EmissivityVeg*(1-EmissivityVeg)*(1-EmissivityGrd)) + (1-VegFrac) * EmissivityGrd + + end associate + + end subroutine SurfaceEmissivity + +end module SurfaceEmissivityMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxBareGroundMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxBareGroundMod.F90 new file mode 100644 index 0000000000..795af0443c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxBareGroundMod.F90 @@ -0,0 +1,227 @@ +module SurfaceEnergyFluxBareGroundMod + +!!! Compute surface energy fluxes and budget for bare ground +!!! Use newton-raphson iteration to solve for ground temperatures +!!! Surface energy balance (bare soil): +!!! Ground level: -RadSwAbsGrd - HeatPrecipAdvBareGrd + RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd = 0 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use VaporPressureSaturationMod, only : VaporPressureSaturation + use ResistanceBareGroundMostMod, only : ResistanceBareGroundMOST + use ResistanceBareGroundChen97Mod, only : ResistanceBareGroundChen97 + + implicit none + +contains + + subroutine SurfaceEnergyFluxBareGround(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: BARE_FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: IndIter ! iteration index + integer :: MoStabParaSgn ! number of times MoStabParaBare changes sign + integer, parameter :: NumIter = 5 ! number of iterations for surface temperature + real(kind=kind_noahmp) :: TemperatureGrdChg ! change in ground temperature, last iteration [K] + real(kind=kind_noahmp) :: LwRadCoeff ! coefficients for LW radiation as function of ts**4 + real(kind=kind_noahmp) :: ShCoeff ! coefficients for sensible heat as function of ts + real(kind=kind_noahmp) :: LhCoeff ! coefficients for latent heat as function of ts + real(kind=kind_noahmp) :: GrdHeatCoeff ! coefficients for ground heat as function of ts + real(kind=kind_noahmp) :: ExchCoeffShTmp ! temporary sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffMomTmp ! temporary momentum heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: MoistureFluxSfc ! moisture flux + real(kind=kind_noahmp) :: VapPresSatWatTmp ! saturated vapor pressure for water [Pa] + real(kind=kind_noahmp) :: VapPresSatIceTmp ! saturated vapor pressure for ice [Pa] + real(kind=kind_noahmp) :: VapPresSatWatTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for water + real(kind=kind_noahmp) :: VapPresSatIceTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for ice + real(kind=kind_noahmp) :: FluxTotCoeff ! temporary total coefficients for all energy flux + real(kind=kind_noahmp) :: EnergyResTmp ! temporary energy residual + real(kind=kind_noahmp) :: HeatSensibleTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: TempTmp ! temporary temperature + real(kind=kind_noahmp) :: TempUnitConv ! Kelvin to degree Celsius with limit -50 to +50 +! local statement function + TempUnitConv(TempTmp) = min(50.0, max(-50.0, (TempTmp-ConstFreezePoint))) + +! -------------------------------------------------------------------- + associate( & + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, logical flag for urban grid + OptSurfaceDrag => noahmp%config%nmlist%OptSurfaceDrag ,& ! in, options for surface layer drag/exchange coefficient + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme (only layer 1) + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at surface reference height + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Zilitinkevich Coefficient for exchange coefficient calculation + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd ,& ! in, raltive humidity in surface soil/snow air space + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! in, ground emissivity + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! in, ground surface resistance [s/m] to evaporation + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length, momentum, ground [m] + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + PsychConstGrd => noahmp%energy%state%PsychConstGrd ,& ! in, psychrometric constant [Pa/K], ground + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity [kg/kg] at bare surface + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! inout, bare ground temperature (K) + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! inout, momentum exchange coeff [m/s)], above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! inout, heat exchange coeff [m/s], above ZeroPlaneDisp, bare ground + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m specific humidity [kg/kg] + ExchCoeffSh2mBare => noahmp%energy%state%ExchCoeffSh2mBare ,& ! out, bare ground 2-m sensible heat exchange coefficient [m/s] + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! out, friction velocity [m/s], vegetated + RoughLenShBareGrd => noahmp%energy%state%RoughLenShBareGrd ,& ! out, roughness length [m], sensible heat, bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd ,& ! out, aerodynamic resistance for water vapor [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + VapPresSatGrdBare => noahmp%energy%state%VapPresSatGrdBare ,& ! out, bare ground saturation vapor pressure [Pa] + VapPresSatGrdBareTempD => noahmp%energy%state%VapPresSatGrdBareTempD ,& ! out, bare ground d(VapPresSat)/dt [Pa/K] + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! out, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + MoStabCorrShBare2m => noahmp%energy%state%MoStabCorrShBare2m ,& ! out, M-O sen heat stability correction, 2m, bare ground + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd & ! out, bare ground heat flux [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! initialization (including variables that do not depend on stability iteration) + TemperatureGrdChg = 0.0 + MoStabParaBare = 0.0 + MoStabParaSgn = 0 + MoStabCorrShBare2m = 0.0 + MoistureFluxSfc = 0.0 + FrictionVelBare = 0.1 + HeatSensibleTmp = 0.0 + LwRadCoeff = EmissivityGrd * ConstStefanBoltzmann + GrdHeatCoeff = 2.0*ThermConductSoilSnow(NumSnowLayerNeg+1)/ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + + ! begin stability iteration for ground temperature and flux + loop3: do IndIter = 1, NumIter + + ! ground roughness length + if ( IndIter == 1 ) then + RoughLenShBareGrd = RoughLenMomGrd + else + RoughLenShBareGrd = RoughLenMomGrd !* exp(-ZilitinkevichCoeff*0.4*258.2*sqrt(FrictionVelBare*RoughLenMomGrd)) + endif + + ! aerodyn resistances between reference heigths and d+z0v + if ( OptSurfaceDrag == 1 ) call ResistanceBareGroundMOST(noahmp, IndIter, HeatSensibleTmp, MoStabParaSgn) + if ( OptSurfaceDrag == 2 ) call ResistanceBareGroundChen97(noahmp, IndIter) + + ! conductance variables for diagnostics + ExchCoeffMomTmp = 1.0 / ResistanceMomBareGrd + ExchCoeffShTmp = 1.0 / ResistanceShBareGrd + + ! ES and d(ES)/dt evaluated at ground temperatue + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + VapPresSatGrdBareTempD = VapPresSatWatTmpD + else + VapPresSatGrdBare = VapPresSatIceTmp + VapPresSatGrdBareTempD = VapPresSatIceTmpD + endif + + ! ground fluxes and temperature change + ShCoeff = DensityAirRefHeight * ConstHeatCapacAir / ResistanceShBareGrd + LhCoeff = DensityAirRefHeight * ConstHeatCapacAir / PsychConstGrd / (ResistanceGrdEvap+ResistanceLhBareGrd) + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = GrdHeatCoeff * (TemperatureGrdBare - TemperatureSoilSnow(NumSnowLayerNeg+1)) + EnergyResTmp = RadSwAbsGrd - RadLwNetBareGrd - HeatSensibleBareGrd - HeatLatentBareGrd - & + HeatGroundBareGrd + HeatPrecipAdvBareGrd + FluxTotCoeff = 4.0*LwRadCoeff*TemperatureGrdBare**3 + ShCoeff + LhCoeff*VapPresSatGrdBareTempD + GrdHeatCoeff + TemperatureGrdChg = EnergyResTmp / FluxTotCoeff + RadLwNetBareGrd = RadLwNetBareGrd + 4.0 * LwRadCoeff * TemperatureGrdBare**3 * TemperatureGrdChg + HeatSensibleBareGrd = HeatSensibleBareGrd + ShCoeff * TemperatureGrdChg + HeatLatentBareGrd = HeatLatentBareGrd + LhCoeff * VapPresSatGrdBareTempD * TemperatureGrdChg + HeatGroundBareGrd = HeatGroundBareGrd + GrdHeatCoeff * TemperatureGrdChg + TemperatureGrdBare = TemperatureGrdBare + TemperatureGrdChg + + ! for computing M-O length + HeatSensibleTmp = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + + ! update specific humidity + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + else + VapPresSatGrdBare = VapPresSatIceTmp + endif + SpecHumiditySfc = 0.622 * (VapPresSatGrdBare*RelHumidityGrd) / & + (PressureAirRefHeight - 0.378 * (VapPresSatGrdBare*RelHumidityGrd)) + MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * LhCoeff * PsychConstGrd / ConstHeatCapacAir + + enddo loop3 ! end stability iteration + + ! if snow on ground and TemperatureGrdBare > freezing point: reset TemperatureGrdBare = freezing point. reevaluate ground fluxes. + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrdBare > ConstFreezePoint) ) then + if ( OptSnowSoilTempTime == 1 ) & + TemperatureGrdBare = ConstFreezePoint + if ( OptSnowSoilTempTime == 3 ) & + TemperatureGrdBare = (1.0-SnowCoverFrac) * TemperatureGrdBare + SnowCoverFrac * ConstFreezePoint ! MB: allow TemperatureGrd>0C during melt v3.7 + + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = RadSwAbsGrd + HeatPrecipAdvBareGrd - & + (RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd) + endif + endif + + ! wind stresses + WindStressEwBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindEastwardRefHeight + WindStressNsBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindNorthwardRefHeight + + ! 2m air temperature + if ( (OptSurfaceDrag == 1) .or. (OptSurfaceDrag == 2) ) then + !ExchCoeffSh2mBare = FrictionVelBare * ConstVonKarman / log((2.0+RoughLenShBareGrd)/RoughLenShBareGrd) + ExchCoeffSh2mBare = FrictionVelBare * ConstVonKarman / & + (log((2.0+RoughLenShBareGrd)/RoughLenShBareGrd) - MoStabCorrShBare2m) + if ( ExchCoeffSh2mBare < 1.0e-5 ) then + TemperatureAir2mBare = TemperatureGrdBare + SpecHumidity2mBare = SpecHumiditySfc + else + TemperatureAir2mBare = TemperatureGrdBare - HeatSensibleBareGrd / & + (DensityAirRefHeight*ConstHeatCapacAir) * 1.0 / ExchCoeffSh2mBare + SpecHumidity2mBare = SpecHumiditySfc - HeatLatentBareGrd / & + (LatHeatVapGrd*DensityAirRefHeight) * (1.0/ExchCoeffSh2mBare + ResistanceGrdEvap) + endif + if ( FlagUrban .eqv. .true. ) SpecHumidity2mBare = SpecHumiditySfc + endif + + ! update ExchCoeffShBare + ExchCoeffShBare = ExchCoeffShTmp + + end associate + + end subroutine SurfaceEnergyFluxBareGround + +end module SurfaceEnergyFluxBareGroundMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxGlacierMod.F90 new file mode 100644 index 0000000000..96dfd84a58 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxGlacierMod.F90 @@ -0,0 +1,231 @@ +module SurfaceEnergyFluxGlacierMod + +!!! Compute surface energy fluxes and budget for bare ground (glacier) +!!! Use newton-raphson iteration to solve for ground temperatures +!!! Surface energy balance (bare soil): +!!! Ground level: -RadSwAbsGrd - HeatPrecipAdvBareGrd + RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd + HeatGroundBareGrd = 0 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use VaporPressureSaturationMod, only : VaporPressureSaturation + use ResistanceBareGroundMostMod, only : ResistanceBareGroundMOST + + implicit none + +contains + + subroutine SurfaceEnergyFluxGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: GLACIER_FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type) , intent(inout) :: noahmp + +! local variables + integer :: IndIter ! iteration index + integer :: MoStabParaSgn ! number of times MoStabParaBare changes sign + integer, parameter :: NumIter = 5 ! number of iterations for surface temperature + real(kind=kind_noahmp) :: TemperatureGrdChg ! change in ground temperature [K], last iteration + real(kind=kind_noahmp) :: LwRadCoeff ! coefficients for longwave radiation as function of ts**4 + real(kind=kind_noahmp) :: ShCoeff ! coefficients for sensible heat as function of ts + real(kind=kind_noahmp) :: LhCoeff ! coefficients for latent heat as function of ts + real(kind=kind_noahmp) :: GrdHeatCoeff ! coefficients for st as function of ts + real(kind=kind_noahmp) :: ExchCoeffShTmp ! temporary sensible heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: ExchCoeffMomTmp ! temporary momentum heat exchange coefficient [m/s] + real(kind=kind_noahmp) :: MoistureFluxSfc ! moisture flux + real(kind=kind_noahmp) :: VapPresSatWatTmp ! saturated vapor pressure for water + real(kind=kind_noahmp) :: VapPresSatIceTmp ! saturated vapor pressure for ice + real(kind=kind_noahmp) :: VapPresSatWatTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for water + real(kind=kind_noahmp) :: VapPresSatIceTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for ice + real(kind=kind_noahmp) :: FluxTotCoeff ! temporary total coefficients for all energy flux + real(kind=kind_noahmp) :: EnergyResTmp ! temporary energy residual + real(kind=kind_noahmp) :: HeatSensibleTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: TempTmp ! temporary temperature + real(kind=kind_noahmp) :: TempUnitConv ! Kelvin to degree Celsius with limit -50 to +50 + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceTmp ! temporary glacier ice content [m3/m3] +! local statement function + TempUnitConv(TempTmp) = min(50.0, max(-50.0, (TempTmp-ConstFreezePoint))) + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of glacier/soil layers + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme (only layer 1) + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, options for glacier treatment + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! in, total glacier/soil water content [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, glacier/soil water content [m3/m3] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvBareGrd => noahmp%energy%flux%HeatPrecipAdvBareGrd ,& ! in, precipitation advected heat - bare ground net [W/m2] + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd ,& ! in, raltive humidity in surface soil/snow air space + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! in, ground emissivity + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! in, ground surface resistance [s/m] to evaporation + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length, momentum, ground [m] + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + PsychConstGrd => noahmp%energy%state%PsychConstGrd ,& ! in, psychrometric constant [Pa/K], ground + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity at surface + TemperatureGrdBare => noahmp%energy%state%TemperatureGrdBare ,& ! inout, bare ground temperature [K] + ExchCoeffMomBare => noahmp%energy%state%ExchCoeffMomBare ,& ! inout, momentum exchange coeff [m/s], above ZeroPlaneDisp, bare ground + ExchCoeffShBare => noahmp%energy%state%ExchCoeffShBare ,& ! inout, heat exchange coeff [m/s], above ZeroPlaneDisp, bare ground + WindStressEwBare => noahmp%energy%state%WindStressEwBare ,& ! out, wind stress: east-west [N/m2] bare ground + WindStressNsBare => noahmp%energy%state%WindStressNsBare ,& ! out, wind stress: north-south [N/m2] bare ground + TemperatureAir2mBare => noahmp%energy%state%TemperatureAir2mBare ,& ! out, 2 m height air temperature [K] bare ground + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m specific humidity [kg/kg] + ExchCoeffSh2mBare => noahmp%energy%state%ExchCoeffSh2mBare ,& ! out, bare ground 2-m sensible heat exchange coefficient [m/s] + FrictionVelBare => noahmp%energy%state%FrictionVelBare ,& ! out, friction velocity [m/s], vegetated + RoughLenShBareGrd => noahmp%energy%state%RoughLenShBareGrd ,& ! out, roughness length [m], sensible heat, bare ground + ResistanceLhBareGrd => noahmp%energy%state%ResistanceLhBareGrd ,& ! out, aerodynamic resistance for water vapor [s/m], bare ground + ResistanceShBareGrd => noahmp%energy%state%ResistanceShBareGrd ,& ! out, aerodynamic resistance for sensible heat [s/m], bare ground + ResistanceMomBareGrd => noahmp%energy%state%ResistanceMomBareGrd ,& ! out, aerodynamic resistance for momentum [s/m], bare ground + VapPresSatGrdBare => noahmp%energy%state%VapPresSatGrdBare ,& ! out, bare ground saturation vapor pressure at TemperatureGrd [Pa] + VapPresSatGrdBareTempD => noahmp%energy%state%VapPresSatGrdBareTempD ,& ! out, bare ground d(VapPresSatGrdBare)/dt at TemperatureGrd [Pa/K] + MoStabParaBare => noahmp%energy%state%MoStabParaBare ,& ! out, Monin-Obukhov stability (z/L), above ZeroPlaneDisp, bare ground + MoStabCorrShBare2m => noahmp%energy%state%MoStabCorrShBare2m ,& ! out, M-O sen heat stability correction, 2m, bare ground + RadLwNetBareGrd => noahmp%energy%flux%RadLwNetBareGrd ,& ! out, net longwave rad [W/m2] bare ground (+ to atm) + HeatSensibleBareGrd => noahmp%energy%flux%HeatSensibleBareGrd ,& ! out, sensible heat flux [W/m2] bare ground (+ to atm) + HeatLatentBareGrd => noahmp%energy%flux%HeatLatentBareGrd ,& ! out, latent heat flux [W/m2] bare ground (+ to atm) + HeatGroundBareGrd => noahmp%energy%flux%HeatGroundBareGrd & ! out, bare ground heat flux [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! initialization (including variables that do not depend on stability iteration) + if (.not. allocated(SoilIceTmp)) allocate(SoilIceTmp(1:NumSoilLayer)) + SoilIceTmp = 0.0 + TemperatureGrdChg = 0.0 + MoStabParaBare = 0.0 + MoStabParaSgn = 0 + MoStabCorrShBare2m = 0.0 + HeatSensibleTmp = 0.0 + MoistureFluxSfc = 0.0 + FrictionVelBare = 0.1 + LwRadCoeff = EmissivityGrd * ConstStefanBoltzmann + GrdHeatCoeff = 2.0*ThermConductSoilSnow(NumSnowLayerNeg+1)/ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + + ! begin stability iteration for ground temperature and flux + loop3: do IndIter = 1, NumIter + + ! ground roughness length + RoughLenShBareGrd = RoughLenMomGrd + + ! aerodyn resistances between heights reference height and d+z0v + call ResistanceBareGroundMOST(noahmp, IndIter, HeatSensibleTmp, MoStabParaSgn) + + ! conductance variables for diagnostics + ExchCoeffMomTmp = 1.0 / ResistanceMomBareGrd + ExchCoeffShTmp = 1.0 / ResistanceShBareGrd + + ! ES and d(ES)/dt evaluated at TemperatureGrd + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + VapPresSatGrdBareTempD = VapPresSatWatTmpD + else + VapPresSatGrdBare = VapPresSatIceTmp + VapPresSatGrdBareTempD = VapPresSatIceTmpD + endif + + ! ground fluxes and temperature change + ShCoeff = DensityAirRefHeight * ConstHeatCapacAir / ResistanceShBareGrd + if ( (SnowDepth > 0.0) .or. (OptGlacierTreatment == 1) ) then + LhCoeff = DensityAirRefHeight * ConstHeatCapacAir / PsychConstGrd / (ResistanceGrdEvap+ResistanceLhBareGrd) + else + LhCoeff = 0.0 ! don't allow any sublimation of glacier in OptGlacierTreatment=2 + endif + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = GrdHeatCoeff * (TemperatureGrdBare - TemperatureSoilSnow(NumSnowLayerNeg+1)) + EnergyResTmp = RadSwAbsGrd - RadLwNetBareGrd - HeatSensibleBareGrd - & + HeatLatentBareGrd - HeatGroundBareGrd + HeatPrecipAdvBareGrd + FluxTotCoeff = 4.0*LwRadCoeff*TemperatureGrdBare**3 + ShCoeff + LhCoeff*VapPresSatGrdBareTempD + GrdHeatCoeff + TemperatureGrdChg = EnergyResTmp / FluxTotCoeff + RadLwNetBareGrd = RadLwNetBareGrd + 4.0 * LwRadCoeff * TemperatureGrdBare**3 * TemperatureGrdChg + HeatSensibleBareGrd = HeatSensibleBareGrd + ShCoeff * TemperatureGrdChg + HeatLatentBareGrd = HeatLatentBareGrd + LhCoeff * VapPresSatGrdBareTempD * TemperatureGrdChg + HeatGroundBareGrd = HeatGroundBareGrd + GrdHeatCoeff * TemperatureGrdChg + TemperatureGrdBare = TemperatureGrdBare + TemperatureGrdChg ! update ground temperature + + ! for computing M-O length + HeatSensibleTmp = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + + ! update specific humidity + TempTmp = TempUnitConv(TemperatureGrdBare) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdBare = VapPresSatWatTmp + else + VapPresSatGrdBare = VapPresSatIceTmp + endif + SpecHumiditySfc = 0.622 * (VapPresSatGrdBare*RelHumidityGrd) / & + (PressureAirRefHeight - 0.378 * (VapPresSatGrdBare*RelHumidityGrd)) + MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * LhCoeff * PsychConstGrd / ConstHeatCapacAir + + enddo loop3 ! end stability iteration + + ! if snow on ground and TemperatureGrdBare > freezing point: reset TemperatureGrdBare = freezing point. reevaluate ground fluxes. + SoilIceTmp = SoilMoisture - SoilLiqWater + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + if ( (maxval(SoilIceTmp) > 0.0 .or. SnowDepth > 0.05) .and. & + (TemperatureGrdBare > ConstFreezePoint) .and. (OptGlacierTreatment == 1) ) then + TemperatureGrdBare = ConstFreezePoint + TempTmp = TempUnitConv(TemperatureGrdBare) ! MB: recalculate VapPresSatGrdBare + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + VapPresSatGrdBare = VapPresSatIceTmp + SpecHumiditySfc = 0.622 * (VapPresSatGrdBare*RelHumidityGrd) / & + (PressureAirRefHeight - 0.378 * (VapPresSatGrdBare*RelHumidityGrd)) + MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * LhCoeff * PsychConstGrd / ConstHeatCapacAir + RadLwNetBareGrd = LwRadCoeff * TemperatureGrdBare**4 - EmissivityGrd * RadLwDownRefHeight + HeatSensibleBareGrd = ShCoeff * (TemperatureGrdBare - TemperatureAirRefHeight) + HeatLatentBareGrd = LhCoeff * (VapPresSatGrdBare*RelHumidityGrd - PressureVaporRefHeight) + HeatGroundBareGrd = RadSwAbsGrd + HeatPrecipAdvBareGrd - & + (RadLwNetBareGrd + HeatSensibleBareGrd + HeatLatentBareGrd) + endif + endif + + ! wind stresses + WindStressEwBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindEastwardRefHeight + WindStressNsBare = -DensityAirRefHeight * ExchCoeffMomBare * WindSpdRefHeight * WindNorthwardRefHeight + + ! 2m air temperature + ExchCoeffSh2mBare = FrictionVelBare * ConstVonKarman / & + (log((2.0+RoughLenShBareGrd)/RoughLenShBareGrd) - MoStabCorrShBare2m) + if ( ExchCoeffSh2mBare < 1.0e-5 ) then + TemperatureAir2mBare = TemperatureGrdBare + SpecHumidity2mBare = SpecHumiditySfc + else + TemperatureAir2mBare = TemperatureGrdBare - HeatSensibleBareGrd / & + (DensityAirRefHeight*ConstHeatCapacAir) * 1.0 / ExchCoeffSh2mBare + SpecHumidity2mBare = SpecHumiditySfc - HeatLatentBareGrd / & + (LatHeatVapGrd*DensityAirRefHeight) * (1.0/ExchCoeffSh2mBare + ResistanceGrdEvap) + endif + + ! update ExchCoeffShBare + ExchCoeffShBare = ExchCoeffShTmp + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilIceTmp) + + end associate + + end subroutine SurfaceEnergyFluxGlacier + +end module SurfaceEnergyFluxGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxVegetatedMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxVegetatedMod.F90 new file mode 100644 index 0000000000..1283553adc --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceEnergyFluxVegetatedMod.F90 @@ -0,0 +1,428 @@ +module SurfaceEnergyFluxVegetatedMod + +!!! Compute surface energy fluxes and budget for vegetated surface +!!! Use newton-raphson iteration to solve for vegetation and ground temperatures +!!! Surface energy balance: +!!! Canopy level: -RadSwAbsVeg - HeatPrecipAdvCanopy + RadLwNetCanopy + HeatSensibleCanopy + HeatLatentCanEvap + HeatLatentCanTransp + HeatCanStorageChg = 0 +!!! Ground level: -RadSwAbsGrd - HeatPrecipAdvVegGrd + RadLwNetVegGrd + HeatSensibleVegGrd + HeatLatentVegGrd + HeatGroundVegGrd = 0 + + use Machine + use NoahmpVarType + use ConstantDefineMod + use VaporPressureSaturationMod, only : VaporPressureSaturation + use ResistanceAboveCanopyMostMod, only : ResistanceAboveCanopyMOST + use ResistanceAboveCanopyChen97Mod, only : ResistanceAboveCanopyChen97 + use ResistanceLeafToGroundMod, only : ResistanceLeafToGround + use ResistanceCanopyStomataBallBerryMod, only : ResistanceCanopyStomataBallBerry + use ResistanceCanopyStomataJarvisMod, only : ResistanceCanopyStomataJarvis + + implicit none + +contains + + subroutine SurfaceEnergyFluxVegetated(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: VEGE_FLUX +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type) , intent(inout) :: noahmp + +! local variable + integer :: IndIter ! iteration index + integer :: LastIter ! Last iteration + integer :: MoStabParaSgn ! number of times MoStabParaAbvCan changes sign + integer :: IndexShade ! index for sunlit/shaded (0=sunlit;1=shaded) + integer, parameter :: NumIterC = 20 ! number of iterations for surface temperature (5~20) + integer, parameter :: NumIterG = 5 ! number of iterations for ground temperature (3~5) + real(kind=kind_noahmp) :: ExchCoeffShAbvCanTmp ! sensible heat conductance, canopy air to reference height air [m/s] + real(kind=kind_noahmp) :: TemperatureCanChg ! change in tv, last iteration [K] + real(kind=kind_noahmp) :: TemperatureGrdChg ! change in tg, last iteration [K] + real(kind=kind_noahmp) :: LwCoeffAir ! coefficients for longwave emission as function of ts**4 + real(kind=kind_noahmp) :: LwCoeffCan ! coefficients for longwave emission as function of ts**4 + real(kind=kind_noahmp) :: ShCoeff ! coefficients for sensible heat as function of ts + real(kind=kind_noahmp) :: LhCoeff ! coefficients for latent heat as function of ts + real(kind=kind_noahmp) :: GrdHeatCoeff ! coefficients for ground heat as function of ts + real(kind=kind_noahmp) :: TranspHeatCoeff ! coefficients for transpiration heat as function of ts + real(kind=kind_noahmp) :: TempShGhTmp ! partial temperature by sensible and ground heat + real(kind=kind_noahmp) :: ExchCoeffShFrac ! exchange coefficient fraction for sensible heat + real(kind=kind_noahmp) :: VapPresLhTot ! vapor pressure related to total latent heat + real(kind=kind_noahmp) :: ExchCoeffEtFrac ! exchange coefficient fraction for evapotranspiration heat + real(kind=kind_noahmp) :: VapPresSatWatTmp ! saturated vapor pressure for water + real(kind=kind_noahmp) :: VapPresSatIceTmp ! saturated vapor pressure for ice + real(kind=kind_noahmp) :: VapPresSatWatTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for water + real(kind=kind_noahmp) :: VapPresSatIceTmpD ! saturated vapor pressure gradient with ground temp. [Pa/K] for ice + real(kind=kind_noahmp) :: FluxTotCoeff ! temporary total coefficients for all energy flux + real(kind=kind_noahmp) :: EnergyResTmp ! temporary energy residual + real(kind=kind_noahmp) :: ExchCoeffShLeafTmp ! sensible heat conductance, leaf surface to canopy air [m/s] + real(kind=kind_noahmp) :: ExchCoeffTot ! sum of conductances [m/s] + real(kind=kind_noahmp) :: ShCanTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: ShGrdTmp ! temporary sensible heat flux [W/m2] + real(kind=kind_noahmp) :: MoistureFluxSfc ! moisture flux + real(kind=kind_noahmp) :: VegAreaIndTmp ! total leaf area index + stem area index,effective + real(kind=kind_noahmp) :: LeafAreaIndSunEff ! sunlit leaf area index, one-sided [m2/m2],effective + real(kind=kind_noahmp) :: LeafAreaIndShdEff ! shaded leaf area index, one-sided [m2/m2],effective + real(kind=kind_noahmp) :: TempTmp ! temporary temperature + real(kind=kind_noahmp) :: TempUnitConv ! Kelvin to degree Celsius with limit -50 to +50 + real(kind=kind_noahmp) :: HeatCapacCan ! canopy heat capacity [J/m2/K] +! local statement function + TempUnitConv(TempTmp) = min(50.0, max(-50.0, (TempTmp - ConstFreezePoint))) + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, main noahmp timestep [s] + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! in, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + OptSurfaceDrag => noahmp%config%nmlist%OptSurfaceDrag ,& ! in, options for surface layer drag/exchange coefficient + OptStomataResistance => noahmp%config%nmlist%OptStomataResistance ,& ! in, options for canopy stomatal resistance + OptSnowSoilTempTime => noahmp%config%nmlist%OptSnowSoilTempTime ,& ! in, options for snow/soil temperature time scheme (only layer 1) + WindEastwardRefHeight => noahmp%forcing%WindEastwardRefHeight ,& ! in, wind speed [m/s] in eastward direction at reference height + WindNorthwardRefHeight => noahmp%forcing%WindNorthwardRefHeight ,& ! in, wind speed [m/s] in northward direction at reference height + RadLwDownRefHeight => noahmp%forcing%RadLwDownRefHeight ,& ! in, downward longwave radiation [W/m2] at reference height + TemperatureAirRefHeight => noahmp%forcing%TemperatureAirRefHeight ,& ! in, air temperature [K] at reference height + PressureAirRefHeight => noahmp%forcing%PressureAirRefHeight ,& ! in, air pressure [Pa] at reference height + PressureAirSurface => noahmp%forcing%PressureAirSurface ,& ! in, air pressure [Pa] at surface-atmos interface + SnowDepth => noahmp%water%state%SnowDepth ,& ! in, snow depth [m] + SnowCoverFrac => noahmp%water%state%SnowCoverFrac ,& ! in, snow cover fraction + CanopyWetFrac => noahmp%water%state%CanopyWetFrac ,& ! in, wetted or snowed fraction of the canopy + CanopyLiqWater => noahmp%water%state%CanopyLiqWater ,& ! in, canopy intercepted liquid water [mm] + CanopyIce => noahmp%water%state%CanopyIce ,& ! in, canopy intercepted ice [mm] + HeightCanopyTop => noahmp%energy%param%HeightCanopyTop ,& ! in, top of canopy [m] + ZilitinkevichCoeff => noahmp%energy%param%ZilitinkevichCoeff ,& ! in, Zilitinkevich Coefficient for exchange coefficient calculation + HeatCapacCanFac => noahmp%energy%param%HeatCapacCanFac ,& ! in, canopy biomass heat capacity parameter [m] + RadSwAbsVeg => noahmp%energy%flux%RadSwAbsVeg ,& ! in, solar radiation absorbed by vegetation [W/m2] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! in, solar radiation absorbed by ground [W/m2] + HeatPrecipAdvCanopy => noahmp%energy%flux%HeatPrecipAdvCanopy ,& ! in, precipitation advected heat - vegetation net [W/m2] + HeatPrecipAdvVegGrd => noahmp%energy%flux%HeatPrecipAdvVegGrd ,& ! in, precipitation advected heat - under canopy net [W/m2] + RefHeightAboveGrd => noahmp%energy%state%RefHeightAboveGrd ,& ! in, surface reference height [m] + VegFrac => noahmp%energy%state%VegFrac ,& ! in, greeness vegetation fraction + WindSpdRefHeight => noahmp%energy%state%WindSpdRefHeight ,& ! in, wind speed [m/s] at reference height + PressureVaporRefHeight => noahmp%energy%state%PressureVaporRefHeight ,& ! in, vapor pressure air [Pa] at reference height + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! in, one-sided leaf+stem area index [m2/m2] + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! in, sunlit leaf area index, one-sided [m2/m2] + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! in, shaded leaf area index, one-sided [m2/m2] + ZeroPlaneDispSfc => noahmp%energy%state%ZeroPlaneDispSfc ,& ! in, zero plane displacement [m] + RoughLenMomSfc => noahmp%energy%state%RoughLenMomSfc ,& ! in, roughness length [m], momentum, surface + RoughLenMomGrd => noahmp%energy%state%RoughLenMomGrd ,& ! in, roughness length [m], momentum, ground + EmissivityVeg => noahmp%energy%state%EmissivityVeg ,& ! in, vegetation emissivity + EmissivityGrd => noahmp%energy%state%EmissivityGrd ,& ! in, ground emissivity + TemperatureSoilSnow => noahmp%energy%state%TemperatureSoilSnow ,& ! in, snow and soil layer temperature [K] + ThermConductSoilSnow => noahmp%energy%state%ThermConductSoilSnow ,& ! in, thermal conductivity [W/m/K] for all soil & snow + ResistanceGrdEvap => noahmp%energy%state%ResistanceGrdEvap ,& ! in, ground surface resistance [s/m] to evaporation + PsychConstCanopy => noahmp%energy%state%PsychConstCanopy ,& ! in, psychrometric constant [Pa/K], canopy + LatHeatVapCanopy => noahmp%energy%state%LatHeatVapCanopy ,& ! in, latent heat of vaporization/subli [J/kg], canopy + PsychConstGrd => noahmp%energy%state%PsychConstGrd ,& ! in, psychrometric constant [Pa/K], ground + RelHumidityGrd => noahmp%energy%state%RelHumidityGrd ,& ! in, raltive humidity in surface soil/snow air space + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! inout, specific humidity at vegetated surface + PressureVaporCanAir => noahmp%energy%state%PressureVaporCanAir ,& ! inout, canopy air vapor pressure [Pa] + TemperatureCanopyAir => noahmp%energy%state%TemperatureCanopyAir ,& ! inout, canopy air temperature [K] + TemperatureCanopy => noahmp%energy%state%TemperatureCanopy ,& ! inout, vegetation temperature [K] + TemperatureGrdVeg => noahmp%energy%state%TemperatureGrdVeg ,& ! inout, vegetated ground (below-canopy) temperature [K] + ExchCoeffMomAbvCan => noahmp%energy%state%ExchCoeffMomAbvCan ,& ! inout, momentum exchange coeff [m/s], above ZeroPlaneDisp, vegetated + ExchCoeffShAbvCan => noahmp%energy%state%ExchCoeffShAbvCan ,& ! inout, heat exchange coeff [m/s], above ZeroPlaneDisp, vegetated + WindStressEwVeg => noahmp%energy%state%WindStressEwVeg ,& ! out, wind stress: east-west [N/m2] above canopy + WindStressNsVeg => noahmp%energy%state%WindStressNsVeg ,& ! out, wind stress: north-south [N/m2] above canopy + TemperatureAir2mVeg => noahmp%energy%state%TemperatureAir2mVeg ,& ! out, 2 m height air temperature [K], vegetated + ExchCoeffShLeaf => noahmp%energy%state%ExchCoeffShLeaf ,& ! out, sensible heat exchange coeff [m/s],leaf surface to canopy air + ExchCoeffShUndCan => noahmp%energy%state%ExchCoeffShUndCan ,& ! out, under canopy sensible heat exchange coefficient [m/s] + ExchCoeffSh2mVeg => noahmp%energy%state%ExchCoeffSh2mVeg ,& ! out, 2m sensible heat exchange coefficient [m/s] + SpecHumidity2mVeg => noahmp%energy%state%SpecHumidity2mVeg ,& ! out, specific humidity [kg/kg] at 2m vegetated + ResistanceStomataSunlit => noahmp%energy%state%ResistanceStomataSunlit ,& ! out, sunlit leaf stomatal resistance [s/m] + ResistanceStomataShade => noahmp%energy%state%ResistanceStomataShade ,& ! out, shaded leaf stomatal resistance [s/m] + FrictionVelVeg => noahmp%energy%state%FrictionVelVeg ,& ! out, friction velocity [m/s], vegetated + RoughLenShCanopy => noahmp%energy%state%RoughLenShCanopy ,& ! out, roughness length [m], sensible heat, vegetated + RoughLenShVegGrd => noahmp%energy%state%RoughLenShVegGrd ,& ! out, roughness length [m], sensible heat ground, below canopy + ResistanceLeafBoundary => noahmp%energy%state%ResistanceLeafBoundary ,& ! out, bulk leaf boundary layer resistance [s/m] + ResistanceShAbvCan => noahmp%energy%state%ResistanceShAbvCan ,& ! out, aerodynamic resistance for sensible heat [s/m], above canopy + ResistanceLhAbvCan => noahmp%energy%state%ResistanceLhAbvCan ,& ! out, aerodynamic resistance for water vapor [s/m], above canopy + ResistanceShUndCan => noahmp%energy%state%ResistanceShUndCan ,& ! out, ground aerodynamic resistance for sensible heat [s/m] + ResistanceLhUndCan => noahmp%energy%state%ResistanceLhUndCan ,& ! out, ground aerodynamic resistance for water vapor [s/m] + ExchCoeffLhAbvCan => noahmp%energy%state%ExchCoeffLhAbvCan ,& ! out, latent heat conductance, canopy air to reference height [m/s] + ExchCoeffLhTransp => noahmp%energy%state%ExchCoeffLhTransp ,& ! out, transpiration conductance, leaf to canopy air [m/s] + ExchCoeffLhEvap => noahmp%energy%state%ExchCoeffLhEvap ,& ! out, evaporation conductance, leaf to canopy air [m/s] + ExchCoeffLhUndCan => noahmp%energy%state%ExchCoeffLhUndCan ,& ! out, latent heat conductance, ground to canopy air [m/s] + VapPresSatCanopy => noahmp%energy%state%VapPresSatCanopy ,& ! out, saturation vapor pressure at TemperatureCanopy [Pa] + VapPresSatGrdVeg => noahmp%energy%state%VapPresSatGrdVeg ,& ! out, saturation vapor pressure at TemperatureGrd [Pa] + VapPresSatCanTempD => noahmp%energy%state%VapPresSatCanTempD ,& ! out, d(VapPresSatCanopy)/dt at TemperatureCanopy [Pa/K] + VapPresSatGrdVegTempD => noahmp%energy%state%VapPresSatGrdVegTempD ,& ! out, d(VapPresSatGrdVeg)/dt at TemperatureGrd [Pa/K] + CanopyHeight => noahmp%energy%state%CanopyHeight ,& ! out, canopy height [m] + WindSpdCanopyTop => noahmp%energy%state%WindSpdCanopyTop ,& ! out, wind speed at top of canopy [m/s] + MoStabParaAbvCan => noahmp%energy%state%MoStabParaAbvCan ,& ! out, Monin-Obukhov stability (z/L), above ZeroPlaneDispSfc, vegetated + MoStabCorrShVeg2m => noahmp%energy%state%MoStabCorrShVeg2m ,& ! out, M-O sen heat stability correction, 2m, vegetated + RadLwNetCanopy => noahmp%energy%flux%RadLwNetCanopy ,& ! out, canopy net longwave radiation [W/m2] (+ to atm) + HeatSensibleCanopy => noahmp%energy%flux%HeatSensibleCanopy ,& ! out, canopy sensible heat flux [W/m2] (+ to atm) + HeatLatentCanEvap => noahmp%energy%flux%HeatLatentCanEvap ,& ! out, canopy evaporation heat flux [W/m2] (+ to atm) + RadLwNetVegGrd => noahmp%energy%flux%RadLwNetVegGrd ,& ! out, ground net longwave radiation [W/m2] (+ to atm) + HeatSensibleVegGrd => noahmp%energy%flux%HeatSensibleVegGrd ,& ! out, vegetated ground sensible heat flux [W/m2] (+ to atm) + HeatLatentVegGrd => noahmp%energy%flux%HeatLatentVegGrd ,& ! out, ground evaporation heat flux [W/m2] (+ to atm) + HeatLatentCanTransp => noahmp%energy%flux%HeatLatentCanTransp ,& ! out, canopy transpiration heat flux [W/m2] (+ to atm) + HeatCanStorageChg => noahmp%energy%flux%HeatCanStorageChg ,& ! out, canopy heat storage change [W/m2] + HeatGroundVegGrd => noahmp%energy%flux%HeatGroundVegGrd & ! out, vegetated ground heat [W/m2] (+ to soil/snow) + ) +! ---------------------------------------------------------------------- + + ! initialization (including variables that do not depend on stability iteration) + LastIter = 0 + FrictionVelVeg = 0.1 + TemperatureCanChg = 0.0 + TemperatureGrdChg = 0.0 + MoStabParaAbvCan = 0.0 + MoStabParaSgn = 0 + MoStabCorrShVeg2m = 0.0 + ShGrdTmp = 0.0 + ShCanTmp = 0.0 + MoistureFluxSfc = 0.0 + ! limit LeafAreaIndex + VegAreaIndTmp = min(6.0, VegAreaIndEff) + LeafAreaIndSunEff = min(6.0, LeafAreaIndSunlit) + LeafAreaIndShdEff = min(6.0, LeafAreaIndShade) + + ! saturation vapor pressure at ground temperature + TempTmp = TempUnitConv(TemperatureGrdVeg) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdVeg = VapPresSatWatTmp + else + VapPresSatGrdVeg = VapPresSatIceTmp + endif + + ! canopy height + CanopyHeight = HeightCanopyTop + ! wind speed at canopy height + !WindSpdCanopyTop = WindSpdRefHeight * log(CanopyHeight/RoughLenMomSfc) / log(RefHeightAboveGrd/RoughLenMomSfc) + WindSpdCanopyTop = WindSpdRefHeight * log((CanopyHeight - ZeroPlaneDispSfc + RoughLenMomSfc)/RoughLenMomSfc) / & + log(RefHeightAboveGrd/RoughLenMomSfc) ! MB: add ZeroPlaneDispSfc v3.7 + if ( (CanopyHeight-ZeroPlaneDispSfc) <= 0.0 ) then + print*, "CRITICAL PROBLEM: CanopyHeight <= ZeroPlaneDispSfc" + print*, "GridIndexI,GridIndexJ = ", GridIndexI, GridIndexJ + print*, "CanopyHeight = " , CanopyHeight + print*, "ZeroPlaneDispSfc = " , ZeroPlaneDispSfc + print*, "SnowDepth = " , SnowDepth + stop "Error: ZeroPlaneDisp problem in NoahMP LSM" + endif + + ! prepare for longwave rad. + LwCoeffAir = -EmissivityVeg * (1.0 + (1.0-EmissivityVeg)*(1.0-EmissivityGrd)) * RadLwDownRefHeight - & + EmissivityVeg * EmissivityGrd * ConstStefanBoltzmann * TemperatureGrdVeg**4 + LwCoeffCan = (2.0 - EmissivityVeg * (1.0-EmissivityGrd)) * EmissivityVeg * ConstStefanBoltzmann + + ! begin stability iteration for canopy temperature and flux + loop1: do IndIter = 1, NumIterC + + ! ground and surface roughness length + if ( IndIter == 1 ) then + RoughLenShCanopy = RoughLenMomSfc + RoughLenShVegGrd = RoughLenMomGrd + else + RoughLenShCanopy = RoughLenMomSfc !* exp(-ZilitinkevichCoeff*0.4*258.2*sqrt(FrictionVelVeg*RoughLenMomSfc)) + RoughLenShVegGrd = RoughLenMomGrd !* exp(-ZilitinkevichCoeff*0.4*258.2*sqrt(FrictionVelVeg*RoughLenMomGrd)) + endif + + ! aerodyn resistances between RefHeightAboveGrd and d+z0v + if ( OptSurfaceDrag == 1 ) call ResistanceAboveCanopyMOST(noahmp, IndIter, ShCanTmp, MoStabParaSgn) + if ( OptSurfaceDrag == 2 ) call ResistanceAboveCanopyChen97(noahmp, IndIter) + + ! aerodyn resistance between z0g and d+z0v, and leaf boundary layer resistance + call ResistanceLeafToGround(noahmp, IndIter, VegAreaIndTmp, ShGrdTmp) + + ! ES and d(ES)/dt evaluated at TemperatureCanopy + TempTmp = TempUnitConv(TemperatureCanopy) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatCanopy = VapPresSatWatTmp + VapPresSatCanTempD = VapPresSatWatTmpD + else + VapPresSatCanopy = VapPresSatIceTmp + VapPresSatCanTempD = VapPresSatIceTmpD + endif + + ! stomatal resistance + if ( IndIter == 1 ) then + if ( OptStomataResistance == 1 ) then ! Ball-Berry + IndexShade = 0 ! sunlit case + call ResistanceCanopyStomataBallBerry(noahmp, IndexShade) + IndexShade = 1 ! shaded case + call ResistanceCanopyStomataBallBerry(noahmp, IndexShade) + endif + if ( OptStomataResistance == 2 ) then ! Jarvis + IndexShade = 0 ! sunlit case + call ResistanceCanopyStomataJarvis(noahmp, IndexShade) + IndexShade = 1 ! shaded case + call ResistanceCanopyStomataJarvis(noahmp, IndexShade) + endif + endif + + ! sensible heat conductance and coeff above veg. + ExchCoeffShAbvCanTmp = 1.0 / ResistanceShAbvCan + ExchCoeffShLeafTmp = 2.0 * VegAreaIndTmp / ResistanceLeafBoundary + GrdHeatCoeff = 1.0 / ResistanceShUndCan + ExchCoeffTot = ExchCoeffShAbvCanTmp + ExchCoeffShLeafTmp + GrdHeatCoeff + TempShGhTmp = (TemperatureAirRefHeight*ExchCoeffShAbvCanTmp + TemperatureGrdVeg*GrdHeatCoeff) / ExchCoeffTot + ExchCoeffShFrac = ExchCoeffShLeafTmp / ExchCoeffTot + ShCoeff = (1.0 - ExchCoeffShFrac) * DensityAirRefHeight * ConstHeatCapacAir * ExchCoeffShLeafTmp + + ! latent heat conductance and coeff above veg. + ExchCoeffLhAbvCan = 1.0 / ResistanceLhAbvCan + ExchCoeffLhEvap = CanopyWetFrac * VegAreaIndTmp / ResistanceLeafBoundary + ExchCoeffLhTransp = (1.0 - CanopyWetFrac) * (LeafAreaIndSunEff/(ResistanceLeafBoundary+ResistanceStomataSunlit) + & + LeafAreaIndShdEff/(ResistanceLeafBoundary+ResistanceStomataShade)) + ExchCoeffLhUndCan = 1.0 / (ResistanceLhUndCan + ResistanceGrdEvap) + ExchCoeffTot = ExchCoeffLhAbvCan + ExchCoeffLhEvap + ExchCoeffLhTransp + ExchCoeffLhUndCan + VapPresLhTot = (PressureVaporRefHeight*ExchCoeffLhAbvCan + VapPresSatGrdVeg*ExchCoeffLhUndCan ) / ExchCoeffTot + ExchCoeffEtFrac = (ExchCoeffLhEvap + ExchCoeffLhTransp) / ExchCoeffTot + LhCoeff = (1.0 - ExchCoeffEtFrac) * ExchCoeffLhEvap * DensityAirRefHeight * & + ConstHeatCapacAir / PsychConstCanopy ! Barlage: change to vegetation v3.6 + TranspHeatCoeff = (1.0 - ExchCoeffEtFrac) * ExchCoeffLhTransp * DensityAirRefHeight * & + ConstHeatCapacAir / PsychConstCanopy + + ! evaluate surface fluxes with current temperature and solve for temperature change + TemperatureCanopyAir = TempShGhTmp + ExchCoeffShFrac * TemperatureCanopy ! canopy air T. + PressureVaporCanAir = VapPresLhTot + ExchCoeffEtFrac * VapPresSatCanopy ! canopy air e + RadLwNetCanopy = VegFrac * (LwCoeffAir + LwCoeffCan * TemperatureCanopy**4) + HeatSensibleCanopy = VegFrac * DensityAirRefHeight * ConstHeatCapacAir * & + ExchCoeffShLeafTmp * (TemperatureCanopy - TemperatureCanopyAir) + HeatLatentCanEvap = VegFrac * DensityAirRefHeight * ConstHeatCapacAir * ExchCoeffLhEvap * & + (VapPresSatCanopy - PressureVaporCanAir) / PsychConstCanopy ! Barlage: change to v in v3.6 + HeatLatentCanTransp = VegFrac * DensityAirRefHeight * ConstHeatCapacAir * ExchCoeffLhTransp * & + (VapPresSatCanopy - PressureVaporCanAir) / PsychConstCanopy + if ( TemperatureCanopy > ConstFreezePoint ) then + HeatLatentCanEvap = min(CanopyLiqWater*LatHeatVapCanopy/MainTimeStep, HeatLatentCanEvap) ! Barlage: add if block for canopy ice in v3.6 + else + HeatLatentCanEvap = min(CanopyIce*LatHeatVapCanopy/MainTimeStep, HeatLatentCanEvap) + endif + ! canopy heat capacity + HeatCapacCan = HeatCapacCanFac*VegAreaIndTmp*ConstHeatCapacWater + CanopyLiqWater*ConstHeatCapacWater/ConstDensityWater + & + CanopyIce*ConstHeatCapacIce/ConstDensityIce ! [J/m2/K] + ! compute vegetation temperature change + EnergyResTmp = RadSwAbsVeg - RadLwNetCanopy - HeatSensibleCanopy - & + HeatLatentCanEvap - HeatLatentCanTransp + HeatPrecipAdvCanopy + FluxTotCoeff = VegFrac * (4.0*LwCoeffCan*TemperatureCanopy**3 + ShCoeff + & + (LhCoeff+TranspHeatCoeff)*VapPresSatCanTempD + HeatCapacCan/MainTimeStep) ! volumetric heat capacity + TemperatureCanChg = EnergyResTmp / FluxTotCoeff + ! update fluxes with temperature change + RadLwNetCanopy = RadLwNetCanopy + VegFrac * 4.0 * LwCoeffCan * TemperatureCanopy**3 * TemperatureCanChg + HeatSensibleCanopy = HeatSensibleCanopy + VegFrac * ShCoeff * TemperatureCanChg + HeatLatentCanEvap = HeatLatentCanEvap + VegFrac * LhCoeff * VapPresSatCanTempD * TemperatureCanChg + HeatLatentCanTransp = HeatLatentCanTransp + VegFrac * TranspHeatCoeff * VapPresSatCanTempD * TemperatureCanChg + HeatCanStorageChg = VegFrac * HeatCapacCan / MainTimeStep * TemperatureCanChg ! canopy heat storage change [W/m2] + ! update vegetation temperature + TemperatureCanopy = TemperatureCanopy + TemperatureCanChg + !TemperatureCanopyAir = TempShGhTmp + ExchCoeffShFrac * TemperatureCanopy ! canopy air T; update here for consistency + + ! for computing M-O length in the next iteration + ShCanTmp = DensityAirRefHeight * ConstHeatCapacAir * (TemperatureCanopyAir-TemperatureAirRefHeight) / ResistanceShAbvCan + ShGrdTmp = DensityAirRefHeight * ConstHeatCapacAir * (TemperatureGrdVeg-TemperatureCanopyAir) / ResistanceShUndCan + + ! consistent specific humidity from canopy air vapor pressure + SpecHumiditySfc = (0.622 * PressureVaporCanAir) / (PressureAirRefHeight - 0.378 * PressureVaporCanAir) + if ( LastIter == 1 ) then + exit loop1 + endif + if ( (IndIter >= 5) .and. (abs(TemperatureCanChg) <= 0.01) .and. (LastIter == 0) ) then + LastIter = 1 + endif + enddo loop1 ! end stability iteration + + ! under-canopy fluxes and ground temperature + LwCoeffAir = -EmissivityGrd * (1.0 - EmissivityVeg) * RadLwDownRefHeight - & + EmissivityGrd * EmissivityVeg * ConstStefanBoltzmann * TemperatureCanopy**4 + LwCoeffCan = EmissivityGrd * ConstStefanBoltzmann + ShCoeff = DensityAirRefHeight * ConstHeatCapacAir / ResistanceShUndCan + LhCoeff = DensityAirRefHeight * ConstHeatCapacAir / (PsychConstGrd * (ResistanceLhUndCan+ResistanceGrdEvap)) ! Barlage: change to ground v3.6 + GrdHeatCoeff = 2.0 * ThermConductSoilSnow(NumSnowLayerNeg+1) / ThicknessSnowSoilLayer(NumSnowLayerNeg+1) + ! begin stability iteration + loop2: do IndIter = 1, NumIterG + TempTmp = TempUnitConv(TemperatureGrdVeg) + call VaporPressureSaturation(TempTmp, VapPresSatWatTmp, VapPresSatIceTmp, VapPresSatWatTmpD, VapPresSatIceTmpD) + if ( TempTmp > 0.0 ) then + VapPresSatGrdVeg = VapPresSatWatTmp + VapPresSatGrdVegTempD = VapPresSatWatTmpD + else + VapPresSatGrdVeg = VapPresSatIceTmp + VapPresSatGrdVegTempD = VapPresSatIceTmpD + endif + RadLwNetVegGrd = LwCoeffCan * TemperatureGrdVeg**4 + LwCoeffAir + HeatSensibleVegGrd = ShCoeff * (TemperatureGrdVeg - TemperatureCanopyAir) + HeatLatentVegGrd = LhCoeff * (VapPresSatGrdVeg*RelHumidityGrd - PressureVaporCanAir) + HeatGroundVegGrd = GrdHeatCoeff * (TemperatureGrdVeg - TemperatureSoilSnow(NumSnowLayerNeg+1)) + EnergyResTmp = RadSwAbsGrd - RadLwNetVegGrd - HeatSensibleVegGrd - & + HeatLatentVegGrd - HeatGroundVegGrd + HeatPrecipAdvVegGrd + FluxTotCoeff = 4.0 * LwCoeffCan * TemperatureGrdVeg**3 + ShCoeff + LhCoeff*VapPresSatGrdVegTempD + GrdHeatCoeff + TemperatureGrdChg = EnergyResTmp / FluxTotCoeff + RadLwNetVegGrd = RadLwNetVegGrd + 4.0 * LwCoeffCan * TemperatureGrdVeg**3 * TemperatureGrdChg + HeatSensibleVegGrd = HeatSensibleVegGrd + ShCoeff * TemperatureGrdChg + HeatLatentVegGrd = HeatLatentVegGrd + LhCoeff * VapPresSatGrdVegTempD * TemperatureGrdChg + HeatGroundVegGrd = HeatGroundVegGrd + GrdHeatCoeff * TemperatureGrdChg + TemperatureGrdVeg = TemperatureGrdVeg + TemperatureGrdChg + enddo loop2 + !TemperatureCanopyAir = (ExchCoeffShAbvCanTmp*TemperatureAirRefHeight + ExchCoeffShLeafTmp*TemperatureCanopy + & + ! GrdHeatCoeff*TemperatureGrdVeg)/(ExchCoeffShAbvCanTmp + ExchCoeffShLeafTmp + GrdHeatCoeff) + + ! if snow on ground and TemperatureGrdVeg > freezing point: reset TemperatureGrdVeg = freezing point. reevaluate ground fluxes. + if ( (OptSnowSoilTempTime == 1) .or. (OptSnowSoilTempTime == 3) ) then + if ( (SnowDepth > 0.05) .and. (TemperatureGrdVeg > ConstFreezePoint) ) then + if ( OptSnowSoilTempTime == 1 ) & + TemperatureGrdVeg = ConstFreezePoint + if ( OptSnowSoilTempTime == 3 ) & + TemperatureGrdVeg = (1.0 - SnowCoverFrac) * TemperatureGrdVeg + SnowCoverFrac * ConstFreezePoint ! MB: allow TemperatureGrdVeg>0C during melt v3.7 + + RadLwNetVegGrd = LwCoeffCan * TemperatureGrdVeg**4 - EmissivityGrd * (1.0-EmissivityVeg) * RadLwDownRefHeight - & + EmissivityGrd * EmissivityVeg * ConstStefanBoltzmann * TemperatureCanopy**4 + HeatSensibleVegGrd = ShCoeff * (TemperatureGrdVeg - TemperatureCanopyAir) + HeatLatentVegGrd = LhCoeff * (VapPresSatGrdVeg*RelHumidityGrd - PressureVaporCanAir) + HeatGroundVegGrd = RadSwAbsGrd + HeatPrecipAdvVegGrd - (RadLwNetVegGrd + HeatSensibleVegGrd + HeatLatentVegGrd) + endif + endif + + ! wind stresses + WindStressEwVeg = -DensityAirRefHeight * ExchCoeffMomAbvCan * WindSpdRefHeight * WindEastwardRefHeight + WindStressNsVeg = -DensityAirRefHeight * ExchCoeffMomAbvCan * WindSpdRefHeight * WindNorthwardRefHeight + + ! consistent vegetation air temperature and vapor pressure + ! since TemperatureGrdVeg is not consistent with the TemperatureCanopyAir/PressureVaporCanAir calculation. + !TemperatureCanopyAir = TemperatureAirRefHeight + (HeatSensibleVegGrd + HeatSensibleCanopy) / & + ! (DensityAirRefHeight*ConstHeatCapacAir*ExchCoeffShAbvCanTmp) + !TemperatureCanopyAir = TemperatureAirRefHeight + (HeatSensibleVegGrd * VegFrac + HeatSensibleCanopy) / & + ! (DensityAirRefHeight*ConstHeatCapacAir*ExchCoeffShAbvCanTmp) ! ground flux need fveg + !PressureVaporCanAir = PressureVaporRefHeight + (HeatLatentCanEvap+VegFrac*(HeatLatentCanTransp+HeatLatentVegGrd)) / & + ! (DensityAirRefHeight*ExchCoeffLhAbvCan*ConstHeatCapacAir/PsychConstGrd) + !MoistureFluxSfc = (SpecHumiditySfc - SpecHumidityRefHeight) * DensityAirRefHeight * ExchCoeffLhAbvCan !*ConstHeatCapacAir/PsychConstGrd + + ! 2m temperature over vegetation ( corrected for low LH exchange coeff values ) + if ( (OptSurfaceDrag == 1) .or. (OptSurfaceDrag == 2) ) then + !ExchCoeffSh2mVeg = FrictionVelVeg * 1.0 / ConstVonKarman * log((2.0+RoughLenShCanopy)/RoughLenShCanopy) + !ExchCoeffSh2mVeg = FrictionVelVeg * ConstVonKarman / log((2.0+RoughLenShCanopy)/RoughLenShCanopy) + ExchCoeffSh2mVeg = FrictionVelVeg * ConstVonKarman / (log((2.0+RoughLenShCanopy)/RoughLenShCanopy) - MoStabCorrShVeg2m) + if ( ExchCoeffSh2mVeg < 1.0e-5 ) then + TemperatureAir2mVeg = TemperatureCanopyAir + !SpecHumidity2mVeg = (PressureVaporCanAir*0.622/(PressureAirRefHeight - 0.378*PressureVaporCanAir)) + SpecHumidity2mVeg = SpecHumiditySfc + else + TemperatureAir2mVeg = TemperatureCanopyAir - (HeatSensibleVegGrd + HeatSensibleCanopy/VegFrac) / & + (DensityAirRefHeight * ConstHeatCapacAir) * 1.0 / ExchCoeffSh2mVeg + !SpecHumidity2mVeg = (PressureVaporCanAir*0.622/(PressureAirRefHeight - 0.378*PressureVaporCanAir)) - & + ! MoistureFluxSfc/(DensityAirRefHeight*FrictionVelVeg)* 1.0/ConstVonKarman * & + ! log((2.0+RoughLenShCanopy)/RoughLenShCanopy) + SpecHumidity2mVeg = SpecHumiditySfc - ((HeatLatentCanEvap+HeatLatentCanTransp)/VegFrac + HeatLatentVegGrd) / & + (LatHeatVapCanopy * DensityAirRefHeight) * 1.0 / ExchCoeffSh2mVeg + endif + endif + + ! update ExchCoeffSh for output + ExchCoeffShAbvCan = ExchCoeffShAbvCanTmp + ExchCoeffShLeaf = ExchCoeffShLeafTmp + ExchCoeffShUndCan = 1.0 / ResistanceShUndCan + + end associate + + end subroutine SurfaceEnergyFluxVegetated + +end module SurfaceEnergyFluxVegetatedMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationGlacierMod.F90 new file mode 100644 index 0000000000..0d8e2bac71 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationGlacierMod.F90 @@ -0,0 +1,65 @@ +module SurfaceRadiationGlacierMod + +!!! Compute glacier surface radiative fluxes (absorption and reflection) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceRadiationGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: RADIATION_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! waveband indices (1=vis, 2=nir) + real(kind=kind_noahmp) :: RadSwAbsGrdTmp ! ground absorbed solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflGrdTmp ! ground reflected solar radiation [W/m2] + +! ----------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + RadSwDownDir => noahmp%energy%flux%RadSwDownDir ,& ! in, incoming direct solar radiation [W/m2] + RadSwDownDif => noahmp%energy%flux%RadSwDownDif ,& ! in, incoming diffuse solar radiation [W/m2] + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! in, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! in, ground albedo (diffuse: vis, nir) + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! out, solar radiation absorbed by ground [W/m2] + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! out, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc & ! out, total reflected solar radiation [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + RadSwAbsGrd = 0.0 + RadSwAbsSfc = 0.0 + RadSwReflSfc = 0.0 + + do IndBand = 1, NumSwRadBand + ! solar radiation absorbed by glacier surface + RadSwAbsGrdTmp = RadSwDownDir(IndBand) * (1.0 - AlbedoGrdDir(IndBand)) + & + RadSwDownDif(IndBand) * (1.0 - AlbedoGrdDif(IndBand)) + RadSwAbsGrd = RadSwAbsGrd + RadSwAbsGrdTmp + RadSwAbsSfc = RadSwAbsSfc + RadSwAbsGrdTmp + + ! solar radiation reflected by glacier surface + RadSwReflGrdTmp = RadSwDownDir(IndBand) * AlbedoGrdDir(IndBand) + & + RadSwDownDif(IndBand) * AlbedoGrdDif(IndBand) + RadSwReflSfc = RadSwReflSfc + RadSwReflGrdTmp + enddo + + end associate + + end subroutine SurfaceRadiationGlacier + +end module SurfaceRadiationGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationMod.F90 new file mode 100644 index 0000000000..bd9bbb4197 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/SurfaceRadiationMod.F90 @@ -0,0 +1,137 @@ +module SurfaceRadiationMod + +!!! Compute surface (ground and vegetation) radiative fluxes (absorption and reflection) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine SurfaceRadiation(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: SURRAD +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndBand ! waveband indices (1=vis, 2=nir) + real(kind=kind_noahmp) :: MinThr ! prevents overflow for division by zero + real(kind=kind_noahmp) :: RadSwAbsGrdTmp ! ground absorbed solar radiation [W/m2] + real(kind=kind_noahmp) :: RadSwReflSfcNir ! surface reflected solar radiation NIR [W/m2] + real(kind=kind_noahmp) :: RadSwReflSfcVis ! surface reflected solar radiation VIS [W/m2] + real(kind=kind_noahmp) :: LeafAreaIndFrac ! leaf area fraction of canopy + real(kind=kind_noahmp) :: RadSwTranGrdDir ! transmitted solar radiation at ground: direct [W/m2] + real(kind=kind_noahmp) :: RadSwTranGrdDif ! transmitted solar radiation at ground: diffuse [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsCanDir ! direct beam absorbed by canopy [W/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: RadSwAbsCanDif ! diffuse radiation absorbed by canopy [W/m2] + +! -------------------------------------------------------------------- + associate( & + NumSwRadBand => noahmp%config%domain%NumSwRadBand ,& ! in, number of solar radiation wave bands + LeafAreaIndEff => noahmp%energy%state%LeafAreaIndEff ,& ! in, leaf area index, after burying by snow + VegAreaIndEff => noahmp%energy%state%VegAreaIndEff ,& ! in, one-sided leaf+stem area index [m2/m2] + CanopySunlitFrac => noahmp%energy%state%CanopySunlitFrac ,& ! in, sunlit fraction of canopy + CanopyShadeFrac => noahmp%energy%state%CanopyShadeFrac ,& ! in, shaded fraction of canopy + LeafAreaIndSunlit => noahmp%energy%state%LeafAreaIndSunlit ,& ! in, sunlit leaf area + LeafAreaIndShade => noahmp%energy%state%LeafAreaIndShade ,& ! in, shaded leaf area + RadSwDownDir => noahmp%energy%flux%RadSwDownDir ,& ! in, incoming direct solar radiation [W/m2] + RadSwDownDif => noahmp%energy%flux%RadSwDownDif ,& ! in, incoming diffuse solar radiation [W/m2] + RadSwAbsVegDir => noahmp%energy%flux%RadSwAbsVegDir ,& ! in, flux abs by veg (per unit direct flux) + RadSwAbsVegDif => noahmp%energy%flux%RadSwAbsVegDif ,& ! in, flux abs by veg (per unit diffuse flux) + RadSwDirTranGrdDir => noahmp%energy%flux%RadSwDirTranGrdDir ,& ! in, down direct flux below veg (per unit dir flux) + RadSwDifTranGrdDir => noahmp%energy%flux%RadSwDifTranGrdDir ,& ! in, down diffuse flux below veg (per unit dir flux) + RadSwDifTranGrdDif => noahmp%energy%flux%RadSwDifTranGrdDif ,& ! in, down diffuse flux below veg (per unit dif flux) + AlbedoGrdDir => noahmp%energy%state%AlbedoGrdDir ,& ! in, ground albedo (direct beam: vis, nir) + AlbedoGrdDif => noahmp%energy%state%AlbedoGrdDif ,& ! in, ground albedo (diffuse: vis, nir) + AlbedoSfcDir => noahmp%energy%state%AlbedoSfcDir ,& ! in, surface albedo (direct) + AlbedoSfcDif => noahmp%energy%state%AlbedoSfcDif ,& ! in, surface albedo (diffuse) + RadSwReflVegDir => noahmp%energy%flux%RadSwReflVegDir ,& ! in, flux reflected by veg layer (per unit direct flux) + RadSwReflVegDif => noahmp%energy%flux%RadSwReflVegDif ,& ! in, flux reflected by veg layer (per unit diffuse flux) + RadSwReflGrdDir => noahmp%energy%flux%RadSwReflGrdDir ,& ! in, flux reflected by ground (per unit direct flux) + RadSwReflGrdDif => noahmp%energy%flux%RadSwReflGrdDif ,& ! in, flux reflected by ground (per unit diffuse flux) + RadPhotoActAbsSunlit => noahmp%energy%flux%RadPhotoActAbsSunlit ,& ! out, average absorbed par for sunlit leaves [W/m2] + RadPhotoActAbsShade => noahmp%energy%flux%RadPhotoActAbsShade ,& ! out, average absorbed par for shaded leaves [W/m2] + RadSwAbsVeg => noahmp%energy%flux%RadSwAbsVeg ,& ! out, solar radiation absorbed by vegetation [W/m2] + RadSwAbsGrd => noahmp%energy%flux%RadSwAbsGrd ,& ! out, solar radiation absorbed by ground [W/m2] + RadSwAbsSfc => noahmp%energy%flux%RadSwAbsSfc ,& ! out, total absorbed solar radiation [W/m2] + RadSwReflSfc => noahmp%energy%flux%RadSwReflSfc ,& ! out, total reflected solar radiation [W/m2] + RadSwReflVeg => noahmp%energy%flux%RadSwReflVeg ,& ! out, reflected solar radiation by vegetation [W/m2] + RadSwReflGrd => noahmp%energy%flux%RadSwReflGrd & ! out, reflected solar radiation by ground [W/m2] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(RadSwAbsCanDir)) allocate(RadSwAbsCanDir(1:NumSwRadBand)) + if (.not. allocated(RadSwAbsCanDif)) allocate(RadSwAbsCanDif(1:NumSwRadBand)) + MinThr = 1.0e-6 + RadSwAbsCanDir = 0.0 + RadSwAbsCanDif = 0.0 + RadSwAbsGrd = 0.0 + RadSwAbsVeg = 0.0 + RadSwAbsSfc = 0.0 + RadSwReflSfc = 0.0 + RadSwReflVeg = 0.0 + RadSwReflGrd = 0.0 + RadPhotoActAbsSunlit = 0.0 + RadPhotoActAbsShade = 0.0 + + do IndBand = 1, NumSwRadBand + ! absorbed by canopy + RadSwAbsCanDir(IndBand) = RadSwDownDir(IndBand) * RadSwAbsVegDir(IndBand) + RadSwAbsCanDif(IndBand) = RadSwDownDif(IndBand) * RadSwAbsVegDif(IndBand) + RadSwAbsVeg = RadSwAbsVeg + RadSwAbsCanDir(IndBand) + RadSwAbsCanDif(IndBand) + RadSwAbsSfc = RadSwAbsSfc + RadSwAbsCanDir(IndBand) + RadSwAbsCanDif(IndBand) + ! transmitted solar fluxes incident on ground + RadSwTranGrdDir = RadSwDownDir(IndBand) * RadSwDirTranGrdDir(IndBand) + RadSwTranGrdDif = RadSwDownDir(IndBand) * RadSwDifTranGrdDir(IndBand) + & + RadSwDownDif(IndBand) * RadSwDifTranGrdDif(IndBand) + ! solar radiation absorbed by ground surface + RadSwAbsGrdTmp = RadSwTranGrdDir * (1.0 - AlbedoGrdDir(IndBand)) + & + RadSwTranGrdDif * (1.0 - AlbedoGrdDif(IndBand)) + RadSwAbsGrd = RadSwAbsGrd + RadSwAbsGrdTmp + RadSwAbsSfc = RadSwAbsSfc + RadSwAbsGrdTmp + enddo + + ! partition visible canopy absorption to sunlit and shaded fractions + ! to get average absorbed par for sunlit and shaded leaves + LeafAreaIndFrac = LeafAreaIndEff / max(VegAreaIndEff, MinThr) + if ( CanopySunlitFrac > 0.0 ) then + RadPhotoActAbsSunlit = (RadSwAbsCanDir(1) + CanopySunlitFrac * RadSwAbsCanDif(1)) * & + LeafAreaIndFrac / max(LeafAreaIndSunlit, MinThr) + RadPhotoActAbsShade = (CanopyShadeFrac * RadSwAbsCanDif(1)) * & + LeafAreaIndFrac / max(LeafAreaIndShade, MinThr) + else + RadPhotoActAbsSunlit = 0.0 + RadPhotoActAbsShade = (RadSwAbsCanDir(1) + RadSwAbsCanDif(1)) * & + LeafAreaIndFrac / max(LeafAreaIndShade, MinThr) + endif + + ! reflected solar radiation + RadSwReflSfcVis = AlbedoSfcDir(1) * RadSwDownDir(1) + AlbedoSfcDif(1) * RadSwDownDif(1) + RadSwReflSfcNir = AlbedoSfcDir(2) * RadSwDownDir(2) + AlbedoSfcDif(2) * RadSwDownDif(2) + RadSwReflSfc = RadSwReflSfcVis + RadSwReflSfcNir + + ! reflected solar radiation of veg. and ground (combined ground) + RadSwReflVeg = RadSwReflVegDir(1)*RadSwDownDir(1) + RadSwReflVegDif(1)*RadSwDownDif(1) + & + RadSwReflVegDir(2)*RadSwDownDir(2) + RadSwReflVegDif(2)*RadSwDownDif(2) + RadSwReflGrd = RadSwReflGrdDir(1)*RadSwDownDir(1) + RadSwReflGrdDif(1)*RadSwDownDif(1) + & + RadSwReflGrdDir(2)*RadSwDownDir(2) + RadSwReflGrdDif(2)*RadSwDownDif(2) + + ! deallocate local arrays to avoid memory leaks + deallocate(RadSwAbsCanDir) + deallocate(RadSwAbsCanDif) + + end associate + + end subroutine SurfaceRadiation + +end module SurfaceRadiationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageEquiDepthMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageEquiDepthMod.F90 new file mode 100644 index 0000000000..df77856392 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageEquiDepthMod.F90 @@ -0,0 +1,69 @@ +module TileDrainageEquiDepthMod + +!!! Calculate tile drainage equivalent depth (currently used in Hooghoudt's scheme) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine TileDrainageEquiDepth(DrainDepthToImp, DrainTubeDist, DrainTubeRadius, DrainWatHgtAbvImp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TD_EQUIVALENT_DEPTH +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + real(kind=kind_noahmp), intent(in) :: DrainDepthToImp ! tile drainage depth to impermeable layer [m] + real(kind=kind_noahmp), intent(in) :: DrainTubeDist ! distance between two drain tubes or tiles [m] + real(kind=kind_noahmp), intent(in) :: DrainTubeRadius ! effective radius of drains [m] + real(kind=kind_noahmp), intent(out) :: DrainWatHgtAbvImp ! Height of water table in drain Above Impermeable Layer [m] + +! local variables + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: PiMath = 22.0/7.0 ! pi value + real(kind=kind_noahmp) :: DrainAspect ! temporary drain variable + real(kind=kind_noahmp) :: DrainFac ! temporary drain factor + real(kind=kind_noahmp) :: DrainExpFac ! temporary drain exponential factor + real(kind=kind_noahmp) :: DrainFacTmp ! temporary drain factor + +! ---------------------------------------------------------------------- + + ! initialization + DrainFac = 0.0 + DrainExpFac = 0.0 + DrainFacTmp = 0.0 + DrainAspect = (2.0 * PiMath * DrainDepthToImp) / DrainTubeDist + + ! compute tile drainage equivalent depth + if ( DrainAspect > 0.5 ) then + do LoopInd = 1, 45, 2 + DrainExpFac = exp(-2.0 * LoopInd * DrainAspect) + DrainFacTmp = (4.0 * DrainExpFac) / (LoopInd * (1.0-DrainExpFac)) + DrainFac = DrainFac + DrainFacTmp + if ( DrainFacTmp < 1.0e-6 ) then + DrainWatHgtAbvImp = ((PiMath*DrainTubeDist) / 8.0) / & + (log(DrainTubeDist/(PiMath*DrainTubeRadius)) + DrainFac) + exit + endif + enddo + elseif ( DrainAspect < 1.0e-8 ) then + DrainWatHgtAbvImp = DrainDepthToImp + else + DrainFac = ((PiMath*PiMath)/(4.0*DrainAspect)) + (log(DrainAspect/(2.0*PiMath))) + DrainWatHgtAbvImp = ((PiMath*DrainTubeDist) / 8.0) / & + (log(DrainTubeDist/(PiMath*DrainTubeRadius)) + DrainFac) + endif + + if ( (DrainWatHgtAbvImp < 0.0) .and. (LoopInd <= 2) ) DrainWatHgtAbvImp = DrainDepthToImp + + end subroutine TileDrainageEquiDepth + +end module TileDrainageEquiDepthMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageHooghoudtMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageHooghoudtMod.F90 new file mode 100644 index 0000000000..4642a590e1 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageHooghoudtMod.F90 @@ -0,0 +1,188 @@ +module TileDrainageHooghoudtMod + +!!! Calculate tile drainage discharge [mm] based on Hooghoudt's equation + + use Machine + use NoahmpVarType + use ConstantDefineMod + use TileDrainageEquiDepthMod, only : TileDrainageEquiDepth + use WaterTableDepthSearchMod, only : WaterTableDepthSearch + use WaterTableEquilibriumMod, only : WaterTableEquilibrium + + implicit none + +contains + + subroutine TileDrainageHooghoudt(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TILE_HOOGHOUDT +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! soil layer loop index + integer :: NumDrain ! number of drains + real(kind=kind_noahmp) :: ThickSatZoneTot ! total thickness of saturated zone + real(kind=kind_noahmp) :: LateralFlow ! lateral flow + real(kind=kind_noahmp) :: DepthToLayerTop ! depth to top of the layer + real(kind=kind_noahmp) :: WatTblTmp1 ! temporary water table variable + real(kind=kind_noahmp) :: WatTblTmp2 ! temporary water table variable + real(kind=kind_noahmp) :: LateralWatCondAve ! average lateral hydruaic conductivity + real(kind=kind_noahmp) :: DrainWatHgtAbvImp ! Height of water table in the drain Above Impermeable Layer + real(kind=kind_noahmp) :: DepthSfcToImp ! Effective Depth to impermeable layer from soil surface + real(kind=kind_noahmp) :: HgtDrnToWatTbl ! Effective Height between water level in drains to water table MiDpoint + real(kind=kind_noahmp) :: DrainCoeffTmp ! Drainage Coefficient + real(kind=kind_noahmp) :: TileDrainTmp ! temporary drainage discharge + real(kind=kind_noahmp) :: DrainDepthToImpTmp ! drain depth to impermeable layer + real(kind=kind_noahmp) :: WatExcFieldCapTot ! amount of water over field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: ThickSatZone ! thickness of saturated zone + real(kind=kind_noahmp), allocatable, dimension(:) :: LateralWatCondTmp ! lateral hydraulic ocnductivity kth layer + real(kind=kind_noahmp), allocatable, dimension(:) :: WatExcFieldCapTmp ! layer-wise amount of water over field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqWaterAftDrain ! remaining water after tile drain + +! ---------------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + GridSize => noahmp%config%domain%GridSize ,& ! in, noahmp model grid spacing [m] + ThicknessSoilLayer => noahmp%config%domain%ThicknessSoilLayer ,& ! in, soil layer thickness [m] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + TileDrainCoeff => noahmp%water%param%TileDrainCoeff ,& ! in, drainage coefficent [m/day] + DrainDepthToImperv => noahmp%water%param%DrainDepthToImperv ,& ! in, Actual depth to impermeable layer from surface [m] + LateralWatCondFac => noahmp%water%param%LateralWatCondFac ,& ! in, multiplication factor to determine lateral hydraulic conductivity + TileDrainDepth => noahmp%water%param%TileDrainDepth ,& ! in, Depth of drain [m] + DrainTubeDist => noahmp%water%param%DrainTubeDist ,& ! in, distance between two drain tubes or tiles [m] + DrainTubeRadius => noahmp%water%param%DrainTubeRadius ,& ! in, effective radius of drains [m] + SoilWatConductivity => noahmp%water%state%SoilWatConductivity ,& ! in, soil hydraulic conductivity [m/s] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + WaterTableHydro => noahmp%water%state%WaterTableHydro ,& ! in, water table depth estimated in WRF-Hydro fine grids [m] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth ,& ! inout, water table depth [m] + TileDrain => noahmp%water%flux%TileDrain & ! inout, tile drainage [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(ThickSatZone) ) allocate(ThickSatZone (1:NumSoilLayer)) + if (.not. allocated(LateralWatCondTmp) ) allocate(LateralWatCondTmp (1:NumSoilLayer)) + if (.not. allocated(WatExcFieldCapTmp) ) allocate(WatExcFieldCapTmp (1:NumSoilLayer)) + if (.not. allocated(SoilLiqWaterAftDrain)) allocate(SoilLiqWaterAftDrain(1:NumSoilLayer)) + ThickSatZone = 0.0 + LateralWatCondTmp = 0.0 + WatExcFieldCapTmp = 0.0 + SoilLiqWaterAftDrain = 0.0 + DepthToLayerTop = 0.0 + LateralFlow = 0.0 + ThickSatZoneTot = 0.0 + DrainCoeffTmp = TileDrainCoeff * 1000.0 * SoilTimeStep / (24.0 * 3600.0) ! m per day to mm per timestep + + ! Thickness of soil layers + do IndSoil = 1, NumSoilLayer + if ( IndSoil == 1 ) then + ThicknessSoilLayer(IndSoil) = -1.0 * DepthSoilLayer(IndSoil) + else + ThicknessSoilLayer(IndSoil) = (DepthSoilLayer(IndSoil-1) - DepthSoilLayer(IndSoil)) + endif + enddo + +#ifdef WRF_HYDRO + ! Depth to water table from WRF-HYDRO, m + WatTblTmp2 = WaterTableHydro +#else + call WaterTableDepthSearch(noahmp) + !call WaterTableEquilibrium(noahmp) + WatTblTmp2 = WaterTableDepth +#endif + + if ( WatTblTmp2 > DrainDepthToImperv) WatTblTmp2 = DrainDepthToImperv + + ! Depth of saturated zone + do IndSoil = 1, NumSoilLayer + if ( WatTblTmp2 > (-1.0*DepthSoilLayer(IndSoil)) ) then + ThickSatZone(IndSoil) = 0.0 + else + ThickSatZone(IndSoil) = (-1.0 * DepthSoilLayer(IndSoil)) - WatTblTmp2 + WatTblTmp1 = (-1.0 * DepthSoilLayer(IndSoil)) - DepthToLayerTop + if ( ThickSatZone(IndSoil) > WatTblTmp1 ) ThickSatZone(IndSoil) = WatTblTmp1 + endif + DepthToLayerTop = -1.0 * DepthSoilLayer(IndSoil) + enddo + + ! amount of water over field capacity + WatExcFieldCapTot = 0.0 + do IndSoil = 1, NumSoilLayer + WatExcFieldCapTmp(IndSoil) = (SoilLiqWater(IndSoil) - (SoilMoistureFieldCap(IndSoil)-SoilIce(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCapTmp(IndSoil) < 0.0 ) WatExcFieldCapTmp(IndSoil) = 0.0 + WatExcFieldCapTot = WatExcFieldCapTot + WatExcFieldCapTmp(IndSoil) + enddo + + ! lateral hydraulic conductivity and total lateral flow + do IndSoil = 1, NumSoilLayer + LateralWatCondTmp(IndSoil) = SoilWatConductivity(IndSoil) * LateralWatCondFac * SoilTimeStep ! m/s to m/timestep + LateralFlow = LateralFlow + (ThickSatZone(IndSoil) * LateralWatCondTmp(IndSoil)) + ThickSatZoneTot = ThickSatZoneTot + ThickSatZone(IndSoil) + enddo + if ( ThickSatZoneTot < 0.001 ) ThickSatZoneTot = 0.001 ! unit is m + if ( LateralFlow < 0.001 ) LateralFlow = 0.0 ! unit is m + LateralWatCondAve = LateralFlow / ThickSatZoneTot ! lateral hydraulic conductivity per timestep + DrainDepthToImpTmp = DrainDepthToImperv - TileDrainDepth + + call TileDrainageEquiDepth(DrainDepthToImpTmp, DrainTubeDist, DrainTubeRadius, DrainWatHgtAbvImp) + + DepthSfcToImp = DrainWatHgtAbvImp + TileDrainDepth + HgtDrnToWatTbl = TileDrainDepth - WatTblTmp2 + if ( HgtDrnToWatTbl <= 0.0 ) then + TileDrain = 0.0 + else + TileDrain = ((8.0*LateralWatCondAve*DrainWatHgtAbvImp*HgtDrnToWatTbl) + & + (4.0*LateralWatCondAve*HgtDrnToWatTbl*HgtDrnToWatTbl)) / (DrainTubeDist*DrainTubeDist) + endif + TileDrain = TileDrain * 1000.0 ! m per timestep to mm/timestep /one tile + if ( TileDrain <= 0.0 ) TileDrain = 0.0 + if ( TileDrain > DrainCoeffTmp ) TileDrain = DrainCoeffTmp + NumDrain = int(GridSize / DrainTubeDist) + TileDrain = TileDrain * NumDrain + if ( TileDrain > WatExcFieldCapTot ) TileDrain = WatExcFieldCapTot + + ! update soil moisture after drainage: moisture drains from top to bottom + TileDrainTmp = TileDrain + do IndSoil = 1, NumSoilLayer + if ( TileDrainTmp > 0.0) then + if ( (ThickSatZone(IndSoil) > 0.0) .and. (WatExcFieldCapTmp(IndSoil) > 0.0) ) then + SoilLiqWaterAftDrain(IndSoil) = WatExcFieldCapTmp(IndSoil) - TileDrainTmp ! remaining water after tile drain + if ( SoilLiqWaterAftDrain(IndSoil) > 0.0 ) then + SoilLiqWater(IndSoil) = (SoilMoistureFieldCap(IndSoil) - SoilIce(IndSoil)) + & + SoilLiqWaterAftDrain(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce(IndSoil) + exit + else + SoilLiqWater(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce(IndSoil) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + TileDrainTmp = TileDrainTmp - WatExcFieldCapTmp(IndSoil) + endif + endif + endif + enddo + + TileDrain = TileDrain / SoilTimeStep ! mm/s + + ! deallocate local arrays to avoid memory leaks + deallocate(ThickSatZone ) + deallocate(LateralWatCondTmp ) + deallocate(WatExcFieldCapTmp ) + deallocate(SoilLiqWaterAftDrain) + + end associate + + end subroutine TileDrainageHooghoudt + +end module TileDrainageHooghoudtMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageSimpleMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageSimpleMod.F90 new file mode 100644 index 0000000000..d482a4dcb5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/TileDrainageSimpleMod.F90 @@ -0,0 +1,213 @@ +module TileDrainageSimpleMod + +!!! Calculate tile drainage discharge [mm] based on simple model + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine TileDrainageSimple(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TILE_DRAIN +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! soil layer loop index + real(kind=kind_noahmp) :: DrainWatVolTot ! temporary variable for drainage volume [mm] + real(kind=kind_noahmp) :: DrainCoeffTmp ! temporary variable for drainage + real(kind=kind_noahmp) :: DrainWatTmp ! temporary variable for drainage + real(kind=kind_noahmp), allocatable, dimension(:) :: WatExcFieldCap ! temp variable for volume of water above field capacity + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilFieldCapLiq ! Available field capacity = field capacity - SoilIce [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: DrainFracTmp ! tile drainage fraction + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, noahmp soil timestep [s] + ThicknessSoilLayer => noahmp%config%domain%ThicknessSoilLayer ,& ! in, soil layer thickness [m] + TileDrainCoeffSp => noahmp%water%param%TileDrainCoeffSp ,& ! in, drainage coefficient [mm/d] + DrainSoilLayerInd => noahmp%water%param%DrainSoilLayerInd ,& ! in, starting soil layer for drainage + TileDrainTubeDepth => noahmp%water%param%TileDrainTubeDepth ,& ! in, depth of drain tube from the soil surface + DrainFacSoilWat => noahmp%water%param%DrainFacSoilWat ,& ! in, drainage factor for soil moisture + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! in, soil ice content [m3/m3] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + TileDrain => noahmp%water%flux%TileDrain & ! out, tile drainage [mm/s] + ) +! ---------------------------------------------------------------------- + + ! initialization + if (.not. allocated(DrainFracTmp) ) allocate(DrainFracTmp (1:NumSoilLayer)) + if (.not. allocated(SoilFieldCapLiq)) allocate(SoilFieldCapLiq(1:NumSoilLayer)) + if (.not. allocated(WatExcFieldCap) ) allocate(WatExcFieldCap (1:NumSoilLayer)) + DrainFracTmp = 0.0 + SoilFieldCapLiq = 0.0 + DrainWatVolTot = 0.0 + WatExcFieldCap = 0.0 + TileDrain = 0.0 + ThicknessSoilLayer = 0.0 + DrainWatTmp = 0.0 + DrainFracTmp = 0.0 + DrainCoeffTmp = TileDrainCoeffSp * SoilTimeStep / (24.0 * 3600.0) + + do IndSoil = 1, NumSoilLayer + if ( IndSoil == 1 ) then + ThicknessSoilLayer(IndSoil) = -1.0 * DepthSoilLayer(IndSoil) + else + ThicknessSoilLayer(IndSoil) = DepthSoilLayer(IndSoil-1) - DepthSoilLayer(IndSoil) + endif + enddo + if ( DrainSoilLayerInd == 0 ) then ! drainage from one specified layer in NoahmpTable.TBL + IndSoil = TileDrainTubeDepth + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 ! mm + if ( WatExcFieldCap(IndSoil) > 0.0 ) then + if ( WatExcFieldCap(IndSoil) > DrainCoeffTmp ) WatExcFieldCap(IndSoil) = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + WatExcFieldCap(IndSoil) + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + endif + else if ( DrainSoilLayerInd == 1 ) then + do IndSoil = 1, 2 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 ! mm + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 1, 2 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 1, 2 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 2 ) then + do IndSoil = 1, 3 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 1, 3 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 1, 3 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 3 ) then + do IndSoil = 2, 3 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 2, 3 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 2, 3 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - & + (WatExcFieldCap(IndSoil) / (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 4 ) then + do IndSoil = 3, 4 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 3, 4 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 3, 4 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - (WatExcFieldCap(IndSoil) / & + (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + else if ( DrainSoilLayerInd == 5 ) then ! from all the four layers + do IndSoil = 1, 4 + SoilFieldCapLiq(IndSoil) = SoilMoistureFieldCap(IndSoil) - SoilIce (IndSoil) + WatExcFieldCap(IndSoil) = (SoilLiqWater(IndSoil) - (DrainFacSoilWat*SoilFieldCapLiq(IndSoil))) * & + ThicknessSoilLayer(IndSoil) * 1000.0 + if ( WatExcFieldCap(IndSoil) < 0.0 ) WatExcFieldCap(IndSoil) = 0.0 + DrainWatTmp = DrainWatTmp + WatExcFieldCap(IndSoil) + enddo + do IndSoil = 1, 4 + if ( WatExcFieldCap(IndSoil) /= 0.0 ) then + DrainFracTmp(IndSoil) = WatExcFieldCap(IndSoil) / DrainWatTmp + endif + enddo + if ( DrainWatTmp > 0.0 ) then + if ( DrainWatTmp > DrainCoeffTmp ) DrainWatTmp = DrainCoeffTmp + DrainWatVolTot = DrainWatVolTot + DrainWatTmp + do IndSoil = 1, 4 + WatExcFieldCap(IndSoil) = DrainFracTmp(IndSoil) * DrainWatTmp + SoilLiqWater(IndSoil) = SoilLiqWater(IndSoil) - (WatExcFieldCap(IndSoil) / & + (ThicknessSoilLayer(IndSoil) * 1000.0)) + SoilMoisture(IndSoil) = SoilLiqWater(IndSoil) + SoilIce (IndSoil) + enddo + endif + endif + + TileDrain = DrainWatVolTot / SoilTimeStep + + ! deallocate local arrays to avoid memory leaks + deallocate(DrainFracTmp ) + deallocate(SoilFieldCapLiq) + deallocate(WatExcFieldCap ) + + end associate + + end subroutine TileDrainageSimple + +end module TileDrainageSimpleMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/VaporPressureSaturationMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/VaporPressureSaturationMod.F90 new file mode 100644 index 0000000000..09f761f973 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/VaporPressureSaturationMod.F90 @@ -0,0 +1,69 @@ +module VaporPressureSaturationMod + +!!! Calculate saturation vapor pressure and derivative with respect to temperature +!!! using polynomials; over water when t > 0C and over ice when t <= 0C + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine VaporPressureSaturation(T, VapPresSatWat, VapPresSatIce, VapPresSatWatD, VapPresSatIceD) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: ESAT +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + real(kind=kind_noahmp), intent(in) :: T ! air temperature [K] + real(kind=kind_noahmp), intent(out) :: VapPresSatWat ! saturation vapor pressure over water [Pa] + real(kind=kind_noahmp), intent(out) :: VapPresSatIce ! saturation vapor pressure over ice [Pa] + real(kind=kind_noahmp), intent(out) :: VapPresSatWatD ! d(ESAT)/dT over water [Pa/K] + real(kind=kind_noahmp), intent(out) :: VapPresSatIceD ! d(ESAT)/dT over ice [Pa/K] + +! local variable + real(kind=kind_noahmp), parameter :: A0 = 6.107799961 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A1 = 4.436518521e-01 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A2 = 1.428945805e-02 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A3 = 2.650648471e-04 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A4 = 3.031240396e-06 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A5 = 2.034080948e-08 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: A6 = 6.136820929e-11 ! coefficients for ESAT over water + real(kind=kind_noahmp), parameter :: B0 = 6.109177956 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B1 = 5.034698970e-01 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B2 = 1.886013408e-02 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B3 = 4.176223716e-04 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B4 = 5.824720280e-06 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B5 = 4.838803174e-08 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: B6 = 1.838826904e-10 ! coefficients for ESAT over ice + real(kind=kind_noahmp), parameter :: C0 = 4.438099984e-01 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C1 = 2.857002636e-02 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C2 = 7.938054040e-04 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C3 = 1.215215065e-05 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C4 = 1.036561403e-07 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C5 = 3.532421810e-10 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: C6 = -7.090244804e-13 ! coefficients for d(ESAT)/dT over water + real(kind=kind_noahmp), parameter :: D0 = 5.030305237e-01 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D1 = 3.773255020e-02 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D2 = 1.267995369e-03 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D3 = 2.477563108e-05 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D4 = 3.005693132e-07 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D5 = 2.158542548e-09 ! coefficients for d(ESAT)/dT over ice + real(kind=kind_noahmp), parameter :: D6 = 7.131097725e-12 ! coefficients for d(ESAT)/dT over ice + +! ---------------------------------------------------------------------- + + VapPresSatWat = 100.0 * (A0 + T * (A1 + T * (A2 + T * (A3 + T * ( A4 + T * (A5 + T*A6) ) ) ) ) ) + VapPresSatIce = 100.0 * (B0 + T * (B1 + T * (B2 + T * (B3 + T * ( B4 + T * (B5 + T*B6) ) ) ) ) ) + VapPresSatWatD = 100.0 * (C0 + T * (C1 + T * (C2 + T * (C3 + T * ( C4 + T * (C5 + T*C6) ) ) ) ) ) + VapPresSatIceD = 100.0 * (D0 + T * (D1 + T * (D2 + T * (D3 + T * ( D4 + T * (D5 + T*D6) ) ) ) ) ) + + end subroutine VaporPressureSaturation + +end module VaporPressureSaturationMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterMainGlacierMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainGlacierMod.F90 new file mode 100644 index 0000000000..1b11f3cd32 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainGlacierMod.F90 @@ -0,0 +1,158 @@ +module WaterMainGlacierMod + +!!! Main glacier water module including all water relevant processes +!!! snowpack water -> ice water -> runoff + + use Machine + use NoahmpVarType + use ConstantDefineMod + use SnowWaterMainGlacierMod, only : SnowWaterMainGlacier + + implicit none + +contains + + subroutine WaterMainGlacier(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: WATER_GLACIER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + real(kind=kind_noahmp) :: WatReplaceSublim ! replacement water due to sublimation of glacier + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceTmp ! temporary glacier ice content [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqWaterTmp ! temporary glacier liquid water content [m3/m3] + +! -------------------------------------------------------------------- + associate( & + OptGlacierTreatment => noahmp%config%nmlist%OptGlacierTreatment ,& ! in, option for glacier treatment + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + GridIndexI => noahmp%config%domain%GridIndexI ,& ! in, grid index in x-direction + GridIndexJ => noahmp%config%domain%GridIndexJ ,& ! in, grid index in y-direction + VaporizeGrd => noahmp%water%flux%VaporizeGrd ,& ! in, ground vaporize rate total (evap+sublim) [mm/s] + CondenseVapGrd => noahmp%water%flux%CondenseVapGrd ,& ! in, ground vapor condense rate total (dew+frost) [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SnowfallGround => noahmp%water%flux%SnowfallGround ,& ! in, snowfall on the ground [mm/s] + SnowfallDensity => noahmp%water%state%SnowfallDensity ,& ! in, bulk density of snowfall [kg/m3] + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! inout, total ground latent heat [W/m2] (+ to atm) + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/glacier layers [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowWaterEquivPrev => noahmp%water%state%SnowWaterEquivPrev ,& ! inout, snow water equivalent at last time step [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, glacier water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, glacier ice moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total glacier water [m3/m3] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt ,& ! inout, surface ponding [mm] from snowmelt when thin snow has no layer + WaterHeadSfc => noahmp%water%state%WaterHeadSfc ,& ! inout, surface water head [mm)] + SoilSfcInflow => noahmp%water%flux%SoilSfcInflow ,& ! inout, water input on glacier/soil surface [m/s] + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! inout, snow surface frost rate [mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! inout, snow surface sublimation rate [mm/s] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! inout, glacier snow excess flow [mm/s] + SnowDepthIncr => noahmp%water%flux%SnowDepthIncr ,& ! out, snow depth increasing rate [m/s] due to snowfall + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! out, net direct ground evaporation [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [mm/s] + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! out, subsurface runoff [mm/s] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow ,& ! out, total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize + if (.not. allocated(SoilIceTmp) ) allocate(SoilIceTmp (1:NumSoilLayer)) + if (.not. allocated(SoilLiqWaterTmp)) allocate(SoilLiqWaterTmp(1:NumSoilLayer)) + SoilIceTmp = 0.0 + SoilLiqWaterTmp = 0.0 + GlacierExcessFlow = 0.0 + RunoffSubsurface = 0.0 + RunoffSurface = 0.0 + SnowDepthIncr = 0.0 + + ! prepare for water process + SoilIce(:) = max(0.0, SoilMoisture(:)-SoilLiqWater(:)) + SoilIceTmp = SoilIce + SoilLiqWaterTmp = SoilLiqWater + SnowWaterEquivPrev = SnowWaterEquiv + + ! compute soil/snow surface evap/dew rate based on energy flux + VaporizeGrd = max(HeatLatentGrd/LatHeatVapGrd, 0.0) ! positive part of ground latent heat; Barlage change to ground v3.6 + CondenseVapGrd = abs(min(HeatLatentGrd/LatHeatVapGrd, 0.0)) ! negative part of ground latent heat + EvapGroundNet = VaporizeGrd - CondenseVapGrd + + ! snow height increase + SnowDepthIncr = SnowfallGround / SnowfallDensity + + ! ground sublimation and evaporation + SublimSnowSfcIce = VaporizeGrd + + ! ground frost and dew + FrostSnowSfcIce = CondenseVapGrd + + ! snowpack water processs + call SnowWaterMainGlacier(noahmp) + + ! total surface input water to glacier ice + SoilSfcInflow = (PondSfcThinSnwMelt + PondSfcThinSnwComb + PondSfcThinSnwTrans) / MainTimeStep * 0.001 ! convert units (mm/s -> m/s) + if ( NumSnowLayerNeg == 0 ) then + SoilSfcInflow = SoilSfcInflow + (SnowBotOutflow + RainfallGround) * 0.001 + else + SoilSfcInflow = SoilSfcInflow + SnowBotOutflow * 0.001 + endif +#ifdef WRF_HYDRO + SoilSfcInflow = SoilSfcInflow + WaterHeadSfc / MainTimeStep * 0.001 +#endif + + ! surface runoff + RunoffSurface = SoilSfcInflow * 1000.0 ! mm/s + + ! glacier ice water + if ( OptGlacierTreatment == 1 ) then + WatReplaceSublim = 0.0 + do LoopInd = 1, NumSoilLayer + WatReplaceSublim = WatReplaceSublim + ThicknessSnowSoilLayer(LoopInd)*(SoilIce(LoopInd) - & + SoilIceTmp(LoopInd) + SoilLiqWater(LoopInd) - SoilLiqWaterTmp(LoopInd)) + enddo + WatReplaceSublim = WatReplaceSublim * 1000.0 / MainTimeStep ! convert to [mm/s] + SoilIce = min(1.0, SoilIceTmp) + elseif ( OptGlacierTreatment == 2 ) then + SoilIce = 1.0 + endif + SoilLiqWater = 1.0 - SoilIce + + ! use RunoffSubsurface as a water balancer, GlacierExcessFlow is snow that disappears, WatReplaceSublim is + ! water from below that replaces glacier loss + if ( OptGlacierTreatment == 1 ) then + RunoffSubsurface = GlacierExcessFlow + WatReplaceSublim + elseif ( OptGlacierTreatment == 2 ) then + RunoffSubsurface = GlacierExcessFlow + VaporizeGrd = SublimSnowSfcIce + CondenseVapGrd = FrostSnowSfcIce + endif + + if ( OptGlacierTreatment == 2 ) then + EvapGroundNet = VaporizeGrd - CondenseVapGrd + HeatLatentGrd = EvapGroundNet * LatHeatVapGrd + endif + + if ( maxval(SoilIce) < 0.0001 ) then + write(*,*) "GLACIER HAS MELTED AT: ", GridIndexI, GridIndexJ, " ARE YOU SURE THIS SHOULD BE A GLACIER POINT?" + endif + + ! deallocate local arrays to avoid memory leaks + deallocate(SoilIceTmp ) + deallocate(SoilLiqWaterTmp) + + end associate + + end subroutine WaterMainGlacier + +end module WaterMainGlacierMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterMainMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainMod.F90 new file mode 100644 index 0000000000..d737e81e11 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterMainMod.F90 @@ -0,0 +1,209 @@ +module WaterMainMod + +!!! Main water module including all water relevant processes +!!! canopy water -> snowpack water -> soil water -> ground water + + use Machine + use NoahmpVarType + use ConstantDefineMod + use CanopyHydrologyMod, only : CanopyHydrology + use SnowWaterMainMod, only : SnowWaterMain + use IrrigationFloodMod, only : IrrigationFlood + use IrrigationMicroMod, only : IrrigationMicro + use SoilWaterMainMod, only : SoilWaterMain + + implicit none + +contains + + subroutine WaterMain(noahmp) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: WATER +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: LoopInd ! loop index + +! -------------------------------------------------------------------- + associate( & + MainTimeStep => noahmp%config%domain%MainTimeStep ,& ! in, noahmp main time step [s] + SoilTimeStep => noahmp%config%domain%SoilTimeStep ,& ! in, soil process timestep [s] + SurfaceType => noahmp%config%domain%SurfaceType ,& ! in, surface type 1-soil; 2-lake + FlagCropland => noahmp%config%domain%FlagCropland ,& ! in, flag to identify croplands + FlagUrban => noahmp%config%domain%FlagUrban ,& ! in, urban point flag + FlagSoilProcess => noahmp%config%domain%FlagSoilProcess ,& ! in, flag to calculate soil processes + NumSoilTimeStep => noahmp%config%domain%NumSoilTimeStep ,& ! in, number of timesteps for soil process calculation + VaporizeGrd => noahmp%water%flux%VaporizeGrd ,& ! in, ground vaporize rate total (evap+sublim) [mm/s] + CondenseVapGrd => noahmp%water%flux%CondenseVapGrd ,& ! in, ground vapor condense rate total (dew+frost) [mm/s] + RainfallGround => noahmp%water%flux%RainfallGround ,& ! in, ground surface rain rate [mm/s] + SoilTranspFac => noahmp%water%state%SoilTranspFac ,& ! in, soil water transpiration factor (0 to 1) + WaterStorageLakeMax => noahmp%water%param%WaterStorageLakeMax ,& ! in, maximum lake water storage [mm] + NumSoilLayerRoot => noahmp%water%param%NumSoilLayerRoot ,& ! in, number of soil layers with root present + FlagFrozenGround => noahmp%energy%state%FlagFrozenGround ,& ! in, frozen ground (logical) to define latent heat pathway + LatHeatVapGrd => noahmp%energy%state%LatHeatVapGrd ,& ! in, latent heat of vaporization/subli [J/kg], ground + DensityAirRefHeight => noahmp%energy%state%DensityAirRefHeight ,& ! in, density air [kg/m3] + ExchCoeffShSfc => noahmp%energy%state%ExchCoeffShSfc ,& ! in, exchange coefficient [m/s] for heat, surface, grid mean + SpecHumidityRefHeight => noahmp%forcing%SpecHumidityRefHeight ,& ! in, specific humidity [kg/kg] at reference height + HeatLatentGrd => noahmp%energy%flux%HeatLatentGrd ,& ! in, total ground latent heat [W/m2] (+ to atm) + NumSnowLayerNeg => noahmp%config%domain%NumSnowLayerNeg ,& ! inout, actual number of snow layers (negative) + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! inout, thickness of snow/soil layers [m] + SnowWaterEquiv => noahmp%water%state%SnowWaterEquiv ,& ! inout, snow water equivalent [mm] + SnowWaterEquivPrev => noahmp%water%state%SnowWaterEquivPrev ,& ! inout, snow water equivalent at last time step [mm] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! inout, soil water content [m3/m3] + SoilIce => noahmp%water%state%SoilIce ,& ! inout, soil ice moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + WaterStorageLake => noahmp%water%state%WaterStorageLake ,& ! inout, water storage in lake (can be negative) [mm] + PondSfcThinSnwMelt => noahmp%water%state%PondSfcThinSnwMelt ,& ! inout, surface ponding [mm] from snowmelt when thin snow has no layer + WaterHeadSfc => noahmp%water%state%WaterHeadSfc ,& ! inout, surface water head (mm) + IrrigationAmtFlood => noahmp%water%state%IrrigationAmtFlood ,& ! inout, flood irrigation water amount [m] + IrrigationAmtMicro => noahmp%water%state%IrrigationAmtMicro ,& ! inout, micro irrigation water amount [m] + SoilSfcInflow => noahmp%water%flux%SoilSfcInflow ,& ! inout, water input on soil surface [m/s] + EvapSoilSfcLiq => noahmp%water%flux%EvapSoilSfcLiq ,& ! inout, evaporation from soil surface [m/s] + DewSoilSfcLiq => noahmp%water%flux%DewSoilSfcLiq ,& ! inout, soil surface dew rate [mm/s] + FrostSnowSfcIce => noahmp%water%flux%FrostSnowSfcIce ,& ! inout, snow surface frost rate[mm/s] + SublimSnowSfcIce => noahmp%water%flux%SublimSnowSfcIce ,& ! inout, snow surface sublimation rate[mm/s] + TranspWatLossSoil => noahmp%water%flux%TranspWatLossSoil ,& ! inout, transpiration water loss from soil layers [m/s] + GlacierExcessFlow => noahmp%water%flux%GlacierExcessFlow ,& ! inout, glacier excess flow [mm/s] + SoilSfcInflowAcc => noahmp%water%flux%SoilSfcInflowAcc ,& ! inout, accumulated water flux into soil during soil timestep [m/s * dt_soil/dt_main] + EvapSoilSfcLiqAcc => noahmp%water%flux%EvapSoilSfcLiqAcc ,& ! inout, accumulated soil surface evaporation during soil timestep [m/s * dt_soil/dt_main] + TranspWatLossSoilAcc => noahmp%water%flux%TranspWatLossSoilAcc ,& ! inout, accumualted transpiration water loss during soil timestep [m/s * dt_soil/dt_main] + SpecHumidity2mBare => noahmp%energy%state%SpecHumidity2mBare ,& ! out, bare ground 2-m specific humidity [kg/kg] + SpecHumiditySfc => noahmp%energy%state%SpecHumiditySfc ,& ! out, specific humidity at surface [kg/kg] + EvapGroundNet => noahmp%water%flux%EvapGroundNet ,& ! out, net ground (soil/snow) evaporation [mm/s] + Transpiration => noahmp%water%flux%Transpiration ,& ! out, transpiration rate [mm/s] + EvapCanopyNet => noahmp%water%flux%EvapCanopyNet ,& ! out, evaporation of intercepted water [mm/s] + RunoffSurface => noahmp%water%flux%RunoffSurface ,& ! out, surface runoff [mm/dt_soil] per soil timestep + RunoffSubsurface => noahmp%water%flux%RunoffSubsurface ,& ! out, subsurface runoff [mm/dt_soil] per soil timestep + TileDrain => noahmp%water%flux%TileDrain ,& ! out, tile drainage per soil timestep [mm/dt_soil] + SnowBotOutflow => noahmp%water%flux%SnowBotOutflow ,& ! out, total water (snowmelt+rain through pack) out of snow bottom [mm/s] + WaterToAtmosTotal => noahmp%water%flux%WaterToAtmosTotal ,& ! out, total water vapor flux to atmosphere [mm/s] + SoilSfcInflowMean => noahmp%water%flux%SoilSfcInflowMean ,& ! out, mean water flux into soil during soil timestep [m/s] + EvapSoilSfcLiqMean => noahmp%water%flux%EvapSoilSfcLiqMean ,& ! out, mean soil surface evaporation during soil timestep [m/s] + TranspWatLossSoilMean => noahmp%water%flux%TranspWatLossSoilMean ,& ! out, mean transpiration water loss during soil timestep [m/s] + PondSfcThinSnwComb => noahmp%water%state%PondSfcThinSnwComb ,& ! out, surface ponding [mm] from liquid in thin snow layer combination + PondSfcThinSnwTrans => noahmp%water%state%PondSfcThinSnwTrans & ! out, surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + ) +! ---------------------------------------------------------------------- + + ! initialize + TranspWatLossSoil = 0.0 + GlacierExcessFlow = 0.0 + RunoffSubsurface = 0.0 + RunoffSurface = 0.0 + SoilSfcInflow = 0.0 + TileDrain = 0.0 + + ! prepare for water process + SoilIce(:) = max(0.0, SoilMoisture(:)-SoilLiqWater(:)) + SnowWaterEquivPrev = SnowWaterEquiv + ! compute soil/snow surface evap/dew rate based on energy flux + VaporizeGrd = max(HeatLatentGrd/LatHeatVapGrd, 0.0) ! positive part of ground latent heat; Barlage change to ground v3.6 + CondenseVapGrd = abs(min(HeatLatentGrd/LatHeatVapGrd, 0.0)) ! negative part of ground latent heat + EvapGroundNet = VaporizeGrd - CondenseVapGrd + + ! canopy-intercepted snowfall/rainfall, drips, and throughfall + call CanopyHydrology(noahmp) + + ! ground sublimation and evaporation + SublimSnowSfcIce = 0.0 + if ( SnowWaterEquiv > 0.0 ) then + SublimSnowSfcIce = min(VaporizeGrd, SnowWaterEquiv/MainTimeStep) + endif + EvapSoilSfcLiq = VaporizeGrd - SublimSnowSfcIce + + ! ground frost and dew + FrostSnowSfcIce = 0.0 + if ( SnowWaterEquiv > 0.0 ) then + FrostSnowSfcIce = CondenseVapGrd + endif + DewSoilSfcLiq = CondenseVapGrd - FrostSnowSfcIce + + ! snowpack water processs + call SnowWaterMain(noahmp) + + ! treat frozen ground/soil + if ( FlagFrozenGround .eqv. .true. ) then + SoilIce(1) = SoilIce(1) + (DewSoilSfcLiq-EvapSoilSfcLiq) * MainTimeStep / & + (ThicknessSnowSoilLayer(1)*1000.0) + DewSoilSfcLiq = 0.0 + EvapSoilSfcLiq = 0.0 + if ( SoilIce(1) < 0.0 ) then + SoilLiqWater(1) = SoilLiqWater(1) + SoilIce(1) + SoilIce(1) = 0.0 + endif + SoilMoisture(1) = SoilLiqWater(1) + SoilIce(1) + endif + EvapSoilSfcLiq = EvapSoilSfcLiq * 0.001 ! mm/s -> m/s + + ! transpiration mm/s -> m/s + do LoopInd = 1, NumSoilLayerRoot + TranspWatLossSoil(LoopInd) = Transpiration * SoilTranspFac(LoopInd) * 0.001 + enddo + + ! total surface input water to soil mm/s -> m/s + SoilSfcInflow = (PondSfcThinSnwMelt + PondSfcThinSnwComb + PondSfcThinSnwTrans) / & + MainTimeStep * 0.001 ! convert units (mm/s -> m/s) + if ( NumSnowLayerNeg == 0 ) then + SoilSfcInflow = SoilSfcInflow + (SnowBotOutflow + DewSoilSfcLiq + RainfallGround) * 0.001 + else + SoilSfcInflow = SoilSfcInflow + (SnowBotOutflow + DewSoilSfcLiq) * 0.001 + endif + +#ifdef WRF_HYDRO + SoilSfcInflow = SoilSfcInflow + WaterHeadSfc / MainTimeStep * 0.001 +#endif + + ! calculate soil process only at soil timestep + SoilSfcInflowAcc = SoilSfcInflowAcc + SoilSfcInflow + EvapSoilSfcLiqAcc = EvapSoilSfcLiqAcc + EvapSoilSfcLiq + TranspWatLossSoilAcc = TranspWatLossSoilAcc + TranspWatLossSoil + + ! start soil water processes + if ( FlagSoilProcess .eqv. .true. ) then + + ! irrigation: call flood irrigation and add to SoilSfcInflowAcc + if ( (FlagCropland .eqv. .true.) .and. (IrrigationAmtFlood > 0.0) ) call IrrigationFlood(noahmp) + + ! irrigation: call micro irrigation assuming we implement drip in first layer + ! of the Noah-MP. Change layer 1 moisture wrt to MI rate + if ( (FlagCropland .eqv. .true.) .and. (IrrigationAmtMicro > 0.0) ) call IrrigationMicro(noahmp) + + ! compute mean water flux during soil timestep + SoilSfcInflowMean = SoilSfcInflowAcc / NumSoilTimeStep + EvapSoilSfcLiqMean = EvapSoilSfcLiqAcc / NumSoilTimeStep + TranspWatLossSoilMean = TranspWatLossSoilAcc / NumSoilTimeStep + + ! lake/soil water balances + if ( SurfaceType == 2 ) then ! lake + RunoffSurface = 0.0 + if ( WaterStorageLake >= WaterStorageLakeMax ) RunoffSurface = SoilSfcInflowMean*1000.0*SoilTimeStep ! mm per soil timestep + WaterStorageLake = WaterStorageLake + (SoilSfcInflowMean-EvapSoilSfcLiqMean)*1000.0*SoilTimeStep - RunoffSurface ! mm per soil timestep + else ! soil + ! soil water processes (including Top model groundwater and shallow water MMF groundwater) + call SoilWaterMain(noahmp) + endif + + endif ! FlagSoilProcess soil timestep + + ! merge excess glacier snow flow to subsurface runoff + RunoffSubsurface = RunoffSubsurface + GlacierExcessFlow * MainTimeStep ! mm per soil timestep + + ! update surface water vapor flux ! urban - jref + WaterToAtmosTotal = Transpiration + EvapCanopyNet + EvapGroundNet + if ( (FlagUrban .eqv. .true.) ) then + SpecHumiditySfc = WaterToAtmosTotal / (DensityAirRefHeight*ExchCoeffShSfc) + SpecHumidityRefHeight + SpecHumidity2mBare = SpecHumiditySfc + endif + + end associate + + end subroutine WaterMain + +end module WaterMainMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterTableDepthSearchMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableDepthSearchMod.F90 new file mode 100644 index 0000000000..5f396bc90c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableDepthSearchMod.F90 @@ -0,0 +1,77 @@ +module WaterTableDepthSearchMod + +!!! Calculate/search water table depth as on WRF-Hydro/NWM + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine WaterTableDepthSearch(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: TD_FINDZWAT +! Original code: P. Valayamkunnath (NCAR) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + +! in & out variables + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! loop index + integer :: IndSatLayer ! check saturated layer + real(kind=kind_noahmp) :: WaterAvailTmp ! temporary available water + real(kind=kind_noahmp) :: WaterTableDepthTmp ! temporary water table depth [m] + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSoilLayer => noahmp%config%domain%ThicknessSoilLayer ,& ! in, soil layer thickness [m] + SoilMoistureFieldCap => noahmp%water%param%SoilMoistureFieldCap ,& ! in, reference soil moisture (field capacity) [m3/m3] + SoilMoistureWilt => noahmp%water%param%SoilMoistureWilt ,& ! in, wilting point soil moisture [m3/m3] + SoilMoisture => noahmp%water%state%SoilMoisture ,& ! inout, total soil moisture [m3/m3] + WaterTableDepth => noahmp%water%state%WaterTableDepth & ! out, water table depth [m] + ) +! ---------------------------------------------------------------------- + + ! initialization + IndSatLayer = 0 ! indicator for sat. layers + WaterAvailTmp = 0.0 ! set water avail for subsfc rtng = 0. + + ! calculate/search for water table depth + do IndSoil = NumSoilLayer, 1, -1 + if ( (SoilMoisture(IndSoil) >= SoilMoistureFieldCap(IndSoil)) .and. & + (SoilMoistureFieldCap(IndSoil) > SoilMoistureWilt(IndSoil)) ) then + if ( (IndSatLayer == (IndSoil+1)) .or. (IndSoil == NumSoilLayer) ) IndSatLayer = IndSoil + endif + enddo + + if ( IndSatLayer /= 0 ) then + if ( IndSatLayer /= 1 ) then ! soil column is partially sat. + WaterTableDepthTmp = -DepthSoilLayer(IndSatLayer-1) + else ! soil column is fully saturated to sfc. + WaterTableDepthTmp = 0.0 + endif + do IndSoil = IndSatLayer, NumSoilLayer + WaterAvailTmp = WaterAvailTmp + & + (SoilMoisture(IndSoil) - SoilMoistureFieldCap(IndSoil)) * ThicknessSoilLayer(IndSoil) + enddo + else ! no saturated layers... + WaterTableDepthTmp = -DepthSoilLayer(NumSoilLayer) + IndSatLayer = NumSoilLayer + 1 + endif + + WaterTableDepth = WaterTableDepthTmp + + end associate + + end subroutine WaterTableDepthSearch + +end module WaterTableDepthSearchMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterTableEquilibriumMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableEquilibriumMod.F90 new file mode 100644 index 0000000000..932b94a123 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterTableEquilibriumMod.F90 @@ -0,0 +1,76 @@ +module WaterTableEquilibriumMod + +!!! Calculate equilibrium water table depth (Niu et al., 2005) + + use Machine + use NoahmpVarType + use ConstantDefineMod + + implicit none + +contains + + subroutine WaterTableEquilibrium(noahmp) + +! ------------------------ Code history -------------------------------------------------- +! Original Noah-MP subroutine: ZWTEQ +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ---------------------------------------------------------------------------------------- + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + +! local variable + integer :: IndSoil ! do-loop index + integer, parameter :: NumSoilFineLy = 100 ! no. of fine soil layers of 6m soil + real(kind=kind_noahmp) :: WatDeficitCoarse ! water deficit from coarse (4-L) soil moisture profile + real(kind=kind_noahmp) :: WatDeficitFine ! water deficit from fine (100-L) soil moisture profile + real(kind=kind_noahmp) :: ThickSoilFineLy ! layer thickness of the 100-L soil layers to 6.0 m + real(kind=kind_noahmp) :: TmpVar ! temporary variable + real(kind=kind_noahmp), dimension(1:NumSoilFineLy) :: DepthSoilFineLy ! layer-bottom depth of the 100-L soil layers to 6.0 m + +! -------------------------------------------------------------------- + associate( & + NumSoilLayer => noahmp%config%domain%NumSoilLayer ,& ! in, number of soil layers + DepthSoilLayer => noahmp%config%domain%DepthSoilLayer ,& ! in, depth [m] of layer-bottom from soil surface + ThicknessSnowSoilLayer => noahmp%config%domain%ThicknessSnowSoilLayer ,& ! in, thickness of snow/soil layers [m] + SoilLiqWater => noahmp%water%state%SoilLiqWater ,& ! in, soil water content [m3/m3] + SoilMoistureSat => noahmp%water%param%SoilMoistureSat ,& ! in, saturated value of soil moisture [m3/m3] + SoilMatPotentialSat => noahmp%water%param%SoilMatPotentialSat ,& ! in, saturated soil matric potential [m] + SoilExpCoeffB => noahmp%water%param%SoilExpCoeffB ,& ! in, soil B parameter + WaterTableDepth => noahmp%water%state%WaterTableDepth & ! out, water table depth [m] + ) +! ---------------------------------------------------------------------- + + DepthSoilFineLy(1:NumSoilFineLy) = 0.0 + WatDeficitCoarse = 0.0 + do IndSoil = 1, NumSoilLayer + WatDeficitCoarse = WatDeficitCoarse + (SoilMoistureSat(1) - SoilLiqWater(IndSoil)) * & + ThicknessSnowSoilLayer(IndSoil) ! [m] + enddo + + ThickSoilFineLy = 3.0 * (-DepthSoilLayer(NumSoilLayer)) / NumSoilFineLy + do IndSoil = 1, NumSoilFineLy + DepthSoilFineLy(IndSoil) = float(IndSoil) * ThickSoilFineLy + enddo + + WaterTableDepth = -3.0 * DepthSoilLayer(NumSoilLayer) - 0.001 ! initial value [m] + + WatDeficitFine = 0.0 + do IndSoil = 1, NumSoilFineLy + TmpVar = 1.0 + (WaterTableDepth - DepthSoilFineLy(IndSoil)) / SoilMatPotentialSat(1) + WatDeficitFine = WatDeficitFine + SoilMoistureSat(1) * & + (1.0 - TmpVar**(-1.0/SoilExpCoeffB(1))) * ThickSoilFineLy + if ( abs(WatDeficitFine-WatDeficitCoarse) <= 0.01 ) then + WaterTableDepth = DepthSoilFineLy(IndSoil) + exit + endif + enddo + + end associate + + end subroutine WaterTableEquilibrium + +end module WaterTableEquilibriumMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterVarInitMod.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarInitMod.F90 new file mode 100644 index 0000000000..a03d8b4f3c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarInitMod.F90 @@ -0,0 +1,310 @@ +module WaterVarInitMod + +!!! Initialize column (1-D) Noah-MP water variables +!!! Water variables should be first defined in WaterVarType.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + use NoahmpVarType + + implicit none + +contains + +!=== initialize with default values + subroutine WaterVarInitDefault(noahmp) + + implicit none + + type(noahmp_type), intent(inout) :: noahmp + + associate( & + NumSnowLayerMax => noahmp%config%domain%NumSnowLayerMax ,& + NumSoilLayer => noahmp%config%domain%NumSoilLayer & + ) + + ! water state variables + noahmp%water%state%IrrigationCntSprinkler = undefined_int + noahmp%water%state%IrrigationCntMicro = undefined_int + noahmp%water%state%IrrigationCntFlood = undefined_int + noahmp%water%state%IrrigationFracFlood = undefined_real + noahmp%water%state%IrrigationAmtFlood = undefined_real + noahmp%water%state%IrrigationFracMicro = undefined_real + noahmp%water%state%IrrigationAmtMicro = undefined_real + noahmp%water%state%IrrigationFracSprinkler = undefined_real + noahmp%water%state%IrrigationAmtSprinkler = undefined_real + noahmp%water%state%IrrigationFracGrid = undefined_real + noahmp%water%state%CanopyLiqWater = undefined_real + noahmp%water%state%CanopyIce = undefined_real + noahmp%water%state%CanopyTotalWater = undefined_real + noahmp%water%state%CanopyWetFrac = undefined_real + noahmp%water%state%CanopyIceMax = undefined_real + noahmp%water%state%CanopyLiqWaterMax = undefined_real + noahmp%water%state%SnowfallDensity = undefined_real + noahmp%water%state%SnowDepth = undefined_real + noahmp%water%state%SnowWaterEquiv = undefined_real + noahmp%water%state%SnowWaterEquivPrev = undefined_real + noahmp%water%state%SnowCoverFrac = undefined_real + noahmp%water%state%PondSfcThinSnwMelt = undefined_real + noahmp%water%state%PondSfcThinSnwComb = undefined_real + noahmp%water%state%PondSfcThinSnwTrans = undefined_real + noahmp%water%state%SoilIceMax = undefined_real + noahmp%water%state%SoilLiqWaterMin = undefined_real + noahmp%water%state%SoilSaturateFrac = undefined_real + noahmp%water%state%SoilImpervFracMax = undefined_real + noahmp%water%state%SoilMoistureToWT = undefined_real + noahmp%water%state%SoilTranspFacAcc = undefined_real + noahmp%water%state%SoilWaterRootZone = undefined_real + noahmp%water%state%SoilWaterStress = undefined_real + noahmp%water%state%SoilSaturationExcess = undefined_real + noahmp%water%state%RechargeGwDeepWT = undefined_real + noahmp%water%state%RechargeGwShallowWT = undefined_real + noahmp%water%state%WaterTableHydro = undefined_real + noahmp%water%state%WaterTableDepth = undefined_real + noahmp%water%state%WaterStorageAquifer = undefined_real + noahmp%water%state%WaterStorageSoilAqf = undefined_real + noahmp%water%state%WaterStorageLake = undefined_real + noahmp%water%state%WaterStorageTotBeg = undefined_real + noahmp%water%state%WaterBalanceError = undefined_real + noahmp%water%state%WaterStorageTotEnd = undefined_real + noahmp%water%state%WaterHeadSfc = undefined_real + noahmp%water%state%PrecipAreaFrac = undefined_real + noahmp%water%state%TileDrainFrac = undefined_real + noahmp%water%state%FrozenPrecipFrac = undefined_real + + if ( .not. allocated(noahmp%water%state%IndexPhaseChange) ) & + allocate( noahmp%water%state%IndexPhaseChange(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilSupercoolWater) ) & + allocate( noahmp%water%state%SoilSupercoolWater(-NumSnowLayerMax+1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SnowIce) ) & + allocate( noahmp%water%state%SnowIce(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowLiqWater) ) & + allocate( noahmp%water%state%SnowLiqWater(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowIceVol) ) & + allocate( noahmp%water%state%SnowIceVol(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowLiqWaterVol) ) & + allocate( noahmp%water%state%SnowLiqWaterVol(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowIceFracPrev) ) & + allocate( noahmp%water%state%SnowIceFracPrev(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowIceFrac) ) & + allocate( noahmp%water%state%SnowIceFrac(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SnowEffPorosity) ) & + allocate( noahmp%water%state%SnowEffPorosity(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%state%SoilLiqWater) ) & + allocate( noahmp%water%state%SoilLiqWater(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilIce) ) & + allocate( noahmp%water%state%SoilIce(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilMoisture) ) & + allocate( noahmp%water%state%SoilMoisture(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilImpervFrac) ) & + allocate( noahmp%water%state%SoilImpervFrac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilWatConductivity) ) & + allocate( noahmp%water%state%SoilWatConductivity(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilWatDiffusivity) ) & + allocate( noahmp%water%state%SoilWatDiffusivity(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilEffPorosity) ) & + allocate( noahmp%water%state%SoilEffPorosity(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilIceFrac) ) & + allocate( noahmp%water%state%SoilIceFrac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilMoistureEqui) ) & + allocate( noahmp%water%state%SoilMoistureEqui(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilTranspFac) ) & + allocate( noahmp%water%state%SoilTranspFac(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%state%SoilMatPotential) ) & + allocate( noahmp%water%state%SoilMatPotential(1:NumSoilLayer) ) + + noahmp%water%state%IndexPhaseChange (:) = undefined_int + noahmp%water%state%SoilSupercoolWater (:) = undefined_real + noahmp%water%state%SnowIce (:) = undefined_real + noahmp%water%state%SnowLiqWater (:) = undefined_real + noahmp%water%state%SnowIceVol (:) = undefined_real + noahmp%water%state%SnowLiqWaterVol (:) = undefined_real + noahmp%water%state%SnowIceFracPrev (:) = undefined_real + noahmp%water%state%SnowIceFrac (:) = undefined_real + noahmp%water%state%SoilIceFrac (:) = undefined_real + noahmp%water%state%SnowEffPorosity (:) = undefined_real + noahmp%water%state%SoilLiqWater (:) = undefined_real + noahmp%water%state%SoilIce (:) = undefined_real + noahmp%water%state%SoilMoisture (:) = undefined_real + noahmp%water%state%SoilImpervFrac (:) = undefined_real + noahmp%water%state%SoilWatConductivity(:) = undefined_real + noahmp%water%state%SoilWatDiffusivity (:) = undefined_real + noahmp%water%state%SoilEffPorosity (:) = undefined_real + noahmp%water%state%SoilMoistureEqui (:) = undefined_real + noahmp%water%state%SoilTranspFac (:) = undefined_real + noahmp%water%state%SoilMatPotential (:) = undefined_real + + ! water flux variables + noahmp%water%flux%PrecipTotRefHeight = undefined_real + noahmp%water%flux%RainfallRefHeight = undefined_real + noahmp%water%flux%SnowfallRefHeight = undefined_real + noahmp%water%flux%PrecipConvTotRefHeight = undefined_real + noahmp%water%flux%PrecipLargeSclRefHeight = undefined_real + noahmp%water%flux%EvapCanopyNet = undefined_real + noahmp%water%flux%Transpiration = undefined_real + noahmp%water%flux%EvapCanopyLiq = undefined_real + noahmp%water%flux%DewCanopyLiq = undefined_real + noahmp%water%flux%FrostCanopyIce = undefined_real + noahmp%water%flux%SublimCanopyIce = undefined_real + noahmp%water%flux%MeltCanopyIce = undefined_real + noahmp%water%flux%FreezeCanopyLiq = undefined_real + noahmp%water%flux%SnowfallGround = undefined_real + noahmp%water%flux%SnowDepthIncr = undefined_real + noahmp%water%flux%FrostSnowSfcIce = undefined_real + noahmp%water%flux%SublimSnowSfcIce = undefined_real + noahmp%water%flux%RainfallGround = undefined_real + noahmp%water%flux%SnowBotOutflow = undefined_real + noahmp%water%flux%GlacierExcessFlow = undefined_real + noahmp%water%flux%SoilSfcInflow = undefined_real + noahmp%water%flux%RunoffSurface = undefined_real + noahmp%water%flux%RunoffSubsurface = undefined_real + noahmp%water%flux%InfilRateSfc = undefined_real + noahmp%water%flux%EvapSoilSfcLiq = undefined_real + noahmp%water%flux%DrainSoilBot = undefined_real + noahmp%water%flux%RechargeGw = undefined_real + noahmp%water%flux%DischargeGw = undefined_real + noahmp%water%flux%VaporizeGrd = undefined_real + noahmp%water%flux%CondenseVapGrd = undefined_real + noahmp%water%flux%DewSoilSfcLiq = undefined_real + noahmp%water%flux%InterceptCanopyRain = undefined_real + noahmp%water%flux%DripCanopyRain = undefined_real + noahmp%water%flux%ThroughfallRain = undefined_real + noahmp%water%flux%InterceptCanopySnow = undefined_real + noahmp%water%flux%DripCanopySnow = undefined_real + noahmp%water%flux%ThroughfallSnow = undefined_real + noahmp%water%flux%EvapGroundNet = undefined_real + noahmp%water%flux%MeltGroundSnow = undefined_real + noahmp%water%flux%WaterToAtmosTotal = undefined_real + noahmp%water%flux%EvapSoilSfcLiqAcc = undefined_real + noahmp%water%flux%SoilSfcInflowAcc = undefined_real + noahmp%water%flux%SfcWaterTotChgAcc = undefined_real + noahmp%water%flux%PrecipTotAcc = undefined_real + noahmp%water%flux%EvapCanopyNetAcc = undefined_real + noahmp%water%flux%TranspirationAcc = undefined_real + noahmp%water%flux%EvapGroundNetAcc = undefined_real + noahmp%water%flux%EvapSoilSfcLiqMean = undefined_real + noahmp%water%flux%SoilSfcInflowMean = undefined_real + noahmp%water%flux%IrrigationRateFlood = 0.0 + noahmp%water%flux%IrrigationRateMicro = 0.0 + noahmp%water%flux%IrrigationRateSprinkler = 0.0 + noahmp%water%flux%IrriEvapLossSprinkler = 0.0 + noahmp%water%flux%EvapIrriSprinkler = 0.0 + noahmp%water%flux%TileDrain = 0.0 + + if ( .not. allocated(noahmp%water%flux%CompactionSnowAging) ) & + allocate( noahmp%water%flux%CompactionSnowAging(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%CompactionSnowBurden) ) & + allocate( noahmp%water%flux%CompactionSnowBurden(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%CompactionSnowMelt) ) & + allocate( noahmp%water%flux%CompactionSnowMelt(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%CompactionSnowTot) ) & + allocate( noahmp%water%flux%CompactionSnowTot(-NumSnowLayerMax+1:0) ) + if ( .not. allocated(noahmp%water%flux%TranspWatLossSoil) ) & + allocate( noahmp%water%flux%TranspWatLossSoil(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%flux%TranspWatLossSoilAcc) ) & + allocate( noahmp%water%flux%TranspWatLossSoilAcc(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%flux%TranspWatLossSoilMean) ) & + allocate( noahmp%water%flux%TranspWatLossSoilMean(1:NumSoilLayer) ) + + noahmp%water%flux%CompactionSnowAging (:) = undefined_real + noahmp%water%flux%CompactionSnowBurden (:) = undefined_real + noahmp%water%flux%CompactionSnowMelt (:) = undefined_real + noahmp%water%flux%CompactionSnowTot (:) = undefined_real + noahmp%water%flux%TranspWatLossSoil (:) = undefined_real + noahmp%water%flux%TranspWatLossSoilAcc (:) = undefined_real + noahmp%water%flux%TranspWatLossSoilMean(:) = undefined_real + + ! water parameter variables + noahmp%water%param%DrainSoilLayerInd = undefined_int + noahmp%water%param%TileDrainTubeDepth = undefined_int + noahmp%water%param%NumSoilLayerRoot = undefined_int + noahmp%water%param%IrriStopDayBfHarvest = undefined_int + noahmp%water%param%CanopyLiqHoldCap = undefined_real + noahmp%water%param%SnowCompactBurdenFac = undefined_real + noahmp%water%param%SnowCompactAgingFac1 = undefined_real + noahmp%water%param%SnowCompactAgingFac2 = undefined_real + noahmp%water%param%SnowCompactAgingFac3 = undefined_real + noahmp%water%param%SnowCompactAgingMax = undefined_real + noahmp%water%param%SnowViscosityCoeff = undefined_real + noahmp%water%param%SnowLiqFracMax = undefined_real + noahmp%water%param%SnowLiqHoldCap = undefined_real + noahmp%water%param%SnowLiqReleaseFac = undefined_real + noahmp%water%param%IrriFloodRateFac = undefined_real + noahmp%water%param%IrriMicroRate = undefined_real + noahmp%water%param%SoilInfilMaxCoeff = undefined_real + noahmp%water%param%SoilImpervFracCoeff = undefined_real + noahmp%water%param%InfilFacVic = undefined_real + noahmp%water%param%TensionWatDistrInfl = undefined_real + noahmp%water%param%TensionWatDistrShp = undefined_real + noahmp%water%param%FreeWatDistrShp = undefined_real + noahmp%water%param%InfilHeteroDynVic = undefined_real + noahmp%water%param%InfilCapillaryDynVic = undefined_real + noahmp%water%param%InfilFacDynVic = undefined_real + noahmp%water%param%SoilDrainSlope = undefined_real + noahmp%water%param%TileDrainCoeffSp = undefined_real + noahmp%water%param%DrainFacSoilWat = undefined_real + noahmp%water%param%TileDrainCoeff = undefined_real + noahmp%water%param%DrainDepthToImperv = undefined_real + noahmp%water%param%LateralWatCondFac = undefined_real + noahmp%water%param%TileDrainDepth = undefined_real + noahmp%water%param%DrainTubeDist = undefined_real + noahmp%water%param%DrainTubeRadius = undefined_real + noahmp%water%param%DrainWatDepToImperv = undefined_real + noahmp%water%param%RunoffDecayFac = undefined_real + noahmp%water%param%BaseflowCoeff = undefined_real + noahmp%water%param%GridTopoIndex = undefined_real + noahmp%water%param%SoilSfcSatFracMax = undefined_real + noahmp%water%param%SpecYieldGw = undefined_real + noahmp%water%param%MicroPoreContent = undefined_real + noahmp%water%param%WaterStorageLakeMax = undefined_real + noahmp%water%param%SnoWatEqvMaxGlacier = undefined_real + noahmp%water%param%SoilConductivityRef = undefined_real + noahmp%water%param%SoilInfilFacRef = undefined_real + noahmp%water%param%GroundFrzCoeff = undefined_real + noahmp%water%param%IrriTriggerLaiMin = undefined_real + noahmp%water%param%SoilWatDeficitAllow = undefined_real + noahmp%water%param%IrriFloodLossFrac = undefined_real + noahmp%water%param%IrriSprinklerRate = undefined_real + noahmp%water%param%IrriFracThreshold = undefined_real + noahmp%water%param%IrriStopPrecipThr = undefined_real + noahmp%water%param%SnowfallDensityMax = undefined_real + noahmp%water%param%SnowMassFullCoverOld = undefined_real + noahmp%water%param%SoilMatPotentialWilt = undefined_real + noahmp%water%param%SnowMeltFac = undefined_real + noahmp%water%param%SnowCoverFac = undefined_real + + if ( .not. allocated(noahmp%water%param%SoilMoistureSat) ) & + allocate( noahmp%water%param%SoilMoistureSat(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMoistureWilt) ) & + allocate( noahmp%water%param%SoilMoistureWilt(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMoistureFieldCap) ) & + allocate( noahmp%water%param%SoilMoistureFieldCap(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMoistureDry) ) & + allocate( noahmp%water%param%SoilMoistureDry(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilWatDiffusivitySat) ) & + allocate( noahmp%water%param%SoilWatDiffusivitySat(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilWatConductivitySat) ) & + allocate( noahmp%water%param%SoilWatConductivitySat(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilExpCoeffB) ) & + allocate( noahmp%water%param%SoilExpCoeffB(1:NumSoilLayer) ) + if ( .not. allocated(noahmp%water%param%SoilMatPotentialSat) ) & + allocate( noahmp%water%param%SoilMatPotentialSat(1:NumSoilLayer) ) + + noahmp%water%param%SoilMoistureSat (:) = undefined_real + noahmp%water%param%SoilMoistureWilt (:) = undefined_real + noahmp%water%param%SoilMoistureFieldCap (:) = undefined_real + noahmp%water%param%SoilMoistureDry (:) = undefined_real + noahmp%water%param%SoilWatDiffusivitySat (:) = undefined_real + noahmp%water%param%SoilWatConductivitySat(:) = undefined_real + noahmp%water%param%SoilExpCoeffB (:) = undefined_real + noahmp%water%param%SoilMatPotentialSat (:) = undefined_real + + end associate + + end subroutine WaterVarInitDefault + +end module WaterVarInitMod diff --git a/src/core_atmosphere/physics/physics_noahmp/src/WaterVarType.F90 b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarType.F90 new file mode 100644 index 0000000000..2d2f913240 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/src/WaterVarType.F90 @@ -0,0 +1,244 @@ +module WaterVarType + +!!! Define column (1-D) Noah-MP Water variables +!!! Water variable initialization is done in WaterVarInitMod.F90 + +! ------------------------ Code history ----------------------------------- +! Original code: Guo-Yue Niu and Noah-MP team (Niu et al. 2011) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + use Machine + + implicit none + save + private + +!=== define "flux" sub-type of water (water%flux%variable) + type :: flux_type + + real(kind=kind_noahmp) :: RainfallRefHeight ! liquid rainfall rate [mm/s] at reference height + real(kind=kind_noahmp) :: SnowfallRefHeight ! snowfall rate [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipTotRefHeight ! total precipitation [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipConvTotRefHeight ! total convective precipitation [mm/s] at reference height + real(kind=kind_noahmp) :: PrecipLargeSclRefHeight ! large-scale precipitation [mm/s] at reference height + real(kind=kind_noahmp) :: EvapCanopyNet ! net evaporation of canopy intercepted total water [mm/s] + real(kind=kind_noahmp) :: Transpiration ! transpiration rate [mm/s] + real(kind=kind_noahmp) :: EvapCanopyLiq ! canopy liquid water evaporation rate [mm/s] + real(kind=kind_noahmp) :: DewCanopyLiq ! canopy water dew rate [mm/s] + real(kind=kind_noahmp) :: FrostCanopyIce ! canopy ice frost rate [mm/s] + real(kind=kind_noahmp) :: SublimCanopyIce ! canopy ice sublimation rate [mm/s] + real(kind=kind_noahmp) :: MeltCanopyIce ! canopy ice melting rate [mm/s] + real(kind=kind_noahmp) :: FreezeCanopyLiq ! canopy water freezing rate [mm/s] + real(kind=kind_noahmp) :: SnowfallGround ! snowfall on the ground (below canopy) [mm/s] + real(kind=kind_noahmp) :: SnowDepthIncr ! snow depth increasing rate [m/s] due to snowfall + real(kind=kind_noahmp) :: FrostSnowSfcIce ! snow surface ice frost rate[mm/s] + real(kind=kind_noahmp) :: SublimSnowSfcIce ! snow surface ice sublimation rate[mm/s] + real(kind=kind_noahmp) :: RainfallGround ! ground surface rain rate [mm/s] + real(kind=kind_noahmp) :: SnowBotOutflow ! total water (snowmelt + rain through pack) out of snowpack bottom [mm/s] + real(kind=kind_noahmp) :: GlacierExcessFlow ! glacier excess flow [mm/s] + real(kind=kind_noahmp) :: IrrigationRateFlood ! flood irrigation water rate [m/timestep] + real(kind=kind_noahmp) :: IrrigationRateMicro ! micro irrigation water rate [m/timestep] + real(kind=kind_noahmp) :: IrrigationRateSprinkler ! sprinkler irrigation water rate [m/timestep] + real(kind=kind_noahmp) :: IrriEvapLossSprinkler ! loss of irrigation water to evaporation,sprinkler [m/timestep] + real(kind=kind_noahmp) :: SoilSfcInflow ! water input on soil surface [m/s] + real(kind=kind_noahmp) :: RunoffSurface ! surface runoff [mm/s] + real(kind=kind_noahmp) :: RunoffSubsurface ! subsurface runoff [mm/s] + real(kind=kind_noahmp) :: InfilRateSfc ! infiltration rate at surface [m/s] + real(kind=kind_noahmp) :: EvapSoilSfcLiq ! soil surface water evaporation [m/s] + real(kind=kind_noahmp) :: DrainSoilBot ! soil bottom drainage [mm/s] + real(kind=kind_noahmp) :: TileDrain ! tile drainage [mm/s] + real(kind=kind_noahmp) :: RechargeGw ! groundwater recharge rate [mm/s] + real(kind=kind_noahmp) :: DischargeGw ! groundwater discharge rate [mm/s] + real(kind=kind_noahmp) :: VaporizeGrd ! ground vaporize rate total (evap+sublim) [mm/s] + real(kind=kind_noahmp) :: CondenseVapGrd ! ground vapor condense rate total (dew+frost) [mm/s] + real(kind=kind_noahmp) :: DewSoilSfcLiq ! soil surface water dew rate [mm/s] + real(kind=kind_noahmp) :: EvapIrriSprinkler ! evaporation of irrigation water, sprinkler [mm/s] + real(kind=kind_noahmp) :: InterceptCanopyRain ! interception rate for rain [mm/s] + real(kind=kind_noahmp) :: DripCanopyRain ! drip rate for intercepted rain [mm/s] + real(kind=kind_noahmp) :: ThroughfallRain ! throughfall for rain [mm/s] + real(kind=kind_noahmp) :: InterceptCanopySnow ! interception (loading) rate for snowfall [mm/s] + real(kind=kind_noahmp) :: DripCanopySnow ! drip (unloading) rate for intercepted snow [mm/s] + real(kind=kind_noahmp) :: ThroughfallSnow ! throughfall of snowfall [mm/s] + real(kind=kind_noahmp) :: EvapGroundNet ! net ground (soil/snow) evaporation [mm/s] + real(kind=kind_noahmp) :: MeltGroundSnow ! ground snow melting rate [mm/s] + real(kind=kind_noahmp) :: WaterToAtmosTotal ! total surface water vapor flux to atmosphere [mm/s] + real(kind=kind_noahmp) :: EvapSoilSfcLiqAcc ! accumulated soil surface water evaporation per soil timestep [m/s * dt_soil/dt_main] + real(kind=kind_noahmp) :: SoilSfcInflowAcc ! accumulated water input on soil surface per soil timestep [m/s * dt_soil/dt_main] + real(kind=kind_noahmp) :: SfcWaterTotChgAcc ! accumulated snow,soil,canopy water change per soil timestep [mm] + real(kind=kind_noahmp) :: PrecipTotAcc ! accumulated precipitation per soil timestep [mm] + real(kind=kind_noahmp) :: EvapCanopyNetAcc ! accumulated net evaporation of canopy intercepted water per soil timestep [mm] + real(kind=kind_noahmp) :: TranspirationAcc ! accumulated transpiration per soil timestep [mm] + real(kind=kind_noahmp) :: EvapGroundNetAcc ! accumulated net ground (soil/snow) evaporation per soil timestep [mm] + real(kind=kind_noahmp) :: EvapSoilSfcLiqMean ! mean soil surface water evaporation during soil timestep [m/s] + real(kind=kind_noahmp) :: SoilSfcInflowMean ! mean water input on soil surface during soil timestep [m/s] + + real(kind=kind_noahmp), allocatable, dimension(:) :: TranspWatLossSoil ! transpiration water loss from soil layers [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: TranspWatLossSoilAcc ! accumulated transpiration water loss from soil per soil timestep [m/s * dt_soil/dt_main] + real(kind=kind_noahmp), allocatable, dimension(:) :: TranspWatLossSoilMean ! mean transpiration water loss from soil during soil timestep [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowAging ! rate of snow compaction due to destructive metamorphism/aging [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowBurden ! rate of snow compaction due to overburden [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowMelt ! rate of snow compaction due to melt [1/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: CompactionSnowTot ! rate of total snow compaction [fraction/timestep] + + end type flux_type + + +!=== define "state" sub-type of water (water%state%variable) + type :: state_type + + integer :: IrrigationCntSprinkler ! irrigation event number, Sprinkler + integer :: IrrigationCntMicro ! irrigation event number, Micro + integer :: IrrigationCntFlood ! irrigation event number, Flood + real(kind=kind_noahmp) :: CanopyTotalWater ! total (liquid+ice) canopy intercepted water [mm] + real(kind=kind_noahmp) :: CanopyWetFrac ! wetted or snowed fraction of the canopy + real(kind=kind_noahmp) :: SnowfallDensity ! bulk density of snowfall (kg/m3) + real(kind=kind_noahmp) :: CanopyLiqWater ! intercepted canopy liquid water [mm] + real(kind=kind_noahmp) :: CanopyIce ! intercepted canopy ice [mm] + real(kind=kind_noahmp) :: CanopyIceMax ! canopy capacity for snow interception [mm] + real(kind=kind_noahmp) :: CanopyLiqWaterMax ! canopy capacity for rain interception [mm] + real(kind=kind_noahmp) :: SnowDepth ! snow depth [m] + real(kind=kind_noahmp) :: SnowWaterEquiv ! snow water equivalent (ice+liquid) [mm] + real(kind=kind_noahmp) :: SnowWaterEquivPrev ! snow water equivalent at previous time step (mm) + real(kind=kind_noahmp) :: PondSfcThinSnwMelt ! surface ponding [mm] from snowmelt when snow has no layer + real(kind=kind_noahmp) :: PondSfcThinSnwComb ! surface ponding [mm] from liquid in thin snow layer combination + real(kind=kind_noahmp) :: PondSfcThinSnwTrans ! surface ponding [mm] from thin snow liquid during transition from multilayer to no layer + real(kind=kind_noahmp) :: IrrigationFracFlood ! fraction of grid under flood irrigation (0 to 1) + real(kind=kind_noahmp) :: IrrigationAmtFlood ! flood irrigation water amount [m] + real(kind=kind_noahmp) :: IrrigationFracMicro ! fraction of grid under micro irrigation (0 to 1) + real(kind=kind_noahmp) :: IrrigationAmtMicro ! micro irrigation water amount [m] + real(kind=kind_noahmp) :: IrrigationFracSprinkler ! fraction of grid under sprinkler irrigation (0 to 1) + real(kind=kind_noahmp) :: IrrigationAmtSprinkler ! sprinkler irrigation water amount [m] + real(kind=kind_noahmp) :: WaterTableDepth ! water table depth [m] + real(kind=kind_noahmp) :: SoilIceMax ! maximum soil ice content [m3/m3] + real(kind=kind_noahmp) :: SoilLiqWaterMin ! minimum soil liquid water content [m3/m3] + real(kind=kind_noahmp) :: SoilSaturateFrac ! fractional saturated area for soil moisture + real(kind=kind_noahmp) :: SoilImpervFracMax ! maximum soil imperviousness fraction + real(kind=kind_noahmp) :: SoilMoistureToWT ! soil moisture between bottom of the soil and the water table + real(kind=kind_noahmp) :: RechargeGwDeepWT ! groundwater recharge to or from the water table when deep [m] + real(kind=kind_noahmp) :: RechargeGwShallowWT ! groundwater recharge to or from shallow water table [m] + real(kind=kind_noahmp) :: SoilSaturationExcess ! saturation excess of the total soil [m] + real(kind=kind_noahmp) :: WaterTableHydro ! water table depth estimated in WRF-Hydro fine grids [m] + real(kind=kind_noahmp) :: TileDrainFrac ! tile drainage fraction + real(kind=kind_noahmp) :: WaterStorageAquifer ! water storage in aquifer [mm] + real(kind=kind_noahmp) :: WaterStorageSoilAqf ! water storage in aquifer + saturated soil [mm] + real(kind=kind_noahmp) :: WaterStorageLake ! water storage in lake (can be negative) [mm] + real(kind=kind_noahmp) :: WaterHeadSfc ! surface water head [mm] + real(kind=kind_noahmp) :: IrrigationFracGrid ! total irrigation fraction from input for a grid + real(kind=kind_noahmp) :: PrecipAreaFrac ! fraction of the gridcell that receives precipitation + real(kind=kind_noahmp) :: SnowCoverFrac ! snow cover fraction + real(kind=kind_noahmp) :: SoilTranspFacAcc ! accumulated soil water transpiration factor (0 to 1) + real(kind=kind_noahmp) :: FrozenPrecipFrac ! fraction of frozen precip in total precipitation + real(kind=kind_noahmp) :: SoilWaterRootZone ! root zone soil water + real(kind=kind_noahmp) :: SoilWaterStress ! soil water stress + real(kind=kind_noahmp) :: WaterStorageTotBeg ! total water storage [mm] at the begining before NoahMP process + real(kind=kind_noahmp) :: WaterBalanceError ! water balance error [mm] + real(kind=kind_noahmp) :: WaterStorageTotEnd ! total water storage [mm] at the end of NoahMP process + + integer , allocatable, dimension(:) :: IndexPhaseChange ! phase change index (0-none;1-melt;2-refreeze) + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIce ! snow layer ice [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqWater ! snow layer liquid water [mm] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceFracPrev ! ice fraction in snow layers at previous timestep + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceFrac ! ice fraction in snow layers at current timestep + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIceFrac ! ice fraction in soil layers at current timestep + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowEffPorosity ! snow effective porosity [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilLiqWater ! soil liquid moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilIce ! soil ice moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoisture ! total soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilImpervFrac ! fraction of imperviousness due to frozen soil + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatConductivity ! soil hydraulic/water conductivity [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatDiffusivity ! soil water diffusivity [m2/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilEffPorosity ! soil effective porosity [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureEqui ! equilibrium soil water content [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilTranspFac ! soil water transpiration factor (0 to 1) + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowIceVol ! partial volume of snow ice [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SnowLiqWaterVol ! partial volume of snow liquid water [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilSupercoolWater ! supercooled water in soil [kg/m2] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMatPotential ! soil matric potential [m] + + end type state_type + + +!=== define "parameter" sub-type of water (water%param%variable) + type :: parameter_type + + integer :: DrainSoilLayerInd ! starting soil layer for drainage + integer :: TileDrainTubeDepth ! depth [m] of drain tube from the soil surface for simple scheme + integer :: NumSoilLayerRoot ! number of soil layers with root present + integer :: IrriStopDayBfHarvest ! number of days before harvest date to stop irrigation + real(kind=kind_noahmp) :: CanopyLiqHoldCap ! maximum canopy intercepted liquid water per unit veg area index [mm] + real(kind=kind_noahmp) :: SnowCompactBurdenFac ! overburden snow compaction parameter [m3/kg] + real(kind=kind_noahmp) :: SnowCompactAgingFac1 ! snow desctructive metamorphism compaction parameter1 [1/s] + real(kind=kind_noahmp) :: SnowCompactAgingFac2 ! snow desctructive metamorphism compaction parameter2 [1/k] + real(kind=kind_noahmp) :: SnowCompactAgingFac3 ! snow desctructive metamorphism compaction parameter3 + real(kind=kind_noahmp) :: SnowCompactAgingMax ! upper Limit on destructive metamorphism compaction [kg/m3] + real(kind=kind_noahmp) :: SnowViscosityCoeff ! snow viscosity coefficient [kg-s/m2], Anderson1979: 0.52e6~1.38e6 + real(kind=kind_noahmp) :: SnowLiqFracMax ! maximum liquid water fraction in snow + real(kind=kind_noahmp) :: SnowLiqHoldCap ! liquid water holding capacity for snowpack [m3/m3] + real(kind=kind_noahmp) :: SnowLiqReleaseFac ! snowpack water release timescale factor [1/s] + real(kind=kind_noahmp) :: IrriFloodRateFac ! flood irrigation application rate factor + real(kind=kind_noahmp) :: IrriMicroRate ! micro irrigation rate [mm/hr] + real(kind=kind_noahmp) :: SoilInfilMaxCoeff ! parameter to calculate maximum soil infiltration rate + real(kind=kind_noahmp) :: SoilImpervFracCoeff ! parameter to calculate frozen soil impermeable fraction + real(kind=kind_noahmp) :: InfilFacVic ! VIC model infiltration parameter + real(kind=kind_noahmp) :: TensionWatDistrInfl ! Tension water distribution inflection parameter + real(kind=kind_noahmp) :: TensionWatDistrShp ! Tension water distribution shape parameter + real(kind=kind_noahmp) :: FreeWatDistrShp ! Free water distribution shape parameter + real(kind=kind_noahmp) :: InfilHeteroDynVic ! DVIC heterogeniety parameter for infiltration + real(kind=kind_noahmp) :: InfilCapillaryDynVic ! DVIC Mean Capillary Drive (m) for infiltration models + real(kind=kind_noahmp) :: InfilFacDynVic ! DVIC model infiltration parameter + real(kind=kind_noahmp) :: SoilDrainSlope ! slope index for soil drainage + real(kind=kind_noahmp) :: TileDrainCoeffSp ! drainage coefficient [mm d^-1] for simple scheme + real(kind=kind_noahmp) :: DrainFacSoilWat ! drainage factor for soil moisture + real(kind=kind_noahmp) :: TileDrainCoeff ! drainage coefficent [m d^-1] for Hooghoudt scheme + real(kind=kind_noahmp) :: DrainDepthToImperv ! Actual depth of tile drainage to impermeable layer form surface + real(kind=kind_noahmp) :: LateralWatCondFac ! multiplication factor to determine lateral hydraulic conductivity + real(kind=kind_noahmp) :: TileDrainDepth ! Depth of drain [m] for Hooghoudt scheme + real(kind=kind_noahmp) :: DrainTubeDist ! distance between two drain tubes or tiles [m] + real(kind=kind_noahmp) :: DrainTubeRadius ! effective radius of drain tubes [m] + real(kind=kind_noahmp) :: DrainWatDepToImperv ! depth to impervious layer from drain water level [m] + real(kind=kind_noahmp) :: RunoffDecayFac ! runoff decay factor [m^-1] + real(kind=kind_noahmp) :: BaseflowCoeff ! baseflow coefficient [mm/s] + real(kind=kind_noahmp) :: GridTopoIndex ! gridcell mean topgraphic index (global mean) + real(kind=kind_noahmp) :: SoilSfcSatFracMax ! maximum surface soil saturated fraction (global mean) + real(kind=kind_noahmp) :: SpecYieldGw ! specific yield [-] for Niu et al. 2007 groundwater scheme + real(kind=kind_noahmp) :: MicroPoreContent ! microprore content (0.0-1.0), 0.0: close to free drainage + real(kind=kind_noahmp) :: WaterStorageLakeMax ! maximum lake water storage [mm] + real(kind=kind_noahmp) :: SnoWatEqvMaxGlacier ! Maximum SWE allowed at glaciers [mm] + real(kind=kind_noahmp) :: SoilConductivityRef ! Reference Soil Conductivity parameter (used in runoff formulation) + real(kind=kind_noahmp) :: SoilInfilFacRef ! Reference Soil Infiltration Parameter (used in runoff formulation) + real(kind=kind_noahmp) :: GroundFrzCoeff ! Frozen ground parameter to compute frozen soil impervious fraction + real(kind=kind_noahmp) :: IrriTriggerLaiMin ! minimum lai to trigger irrigation + real(kind=kind_noahmp) :: SoilWatDeficitAllow ! management allowable deficit (0-1) + real(kind=kind_noahmp) :: IrriFloodLossFrac ! factor of flood irrigation loss + real(kind=kind_noahmp) :: IrriSprinklerRate ! sprinkler irrigation rate [mm/h] + real(kind=kind_noahmp) :: IrriFracThreshold ! irrigation Fraction threshold in a grid + real(kind=kind_noahmp) :: IrriStopPrecipThr ! precipitation threshold [mm/hr] to stop irrigation trigger + real(kind=kind_noahmp) :: SnowfallDensityMax ! maximum fresh snowfall density [kg/m3] + real(kind=kind_noahmp) :: SnowMassFullCoverOld ! new snow mass to fully cover old snow [mm] + real(kind=kind_noahmp) :: SoilMatPotentialWilt ! soil metric potential for wilting point [m] + real(kind=kind_noahmp) :: SnowMeltFac ! snowmelt m parameter in snow cover fraction calculation + real(kind=kind_noahmp) :: SnowCoverFac ! snow cover factor [m] (originally hard-coded 2.5*z0 in SCF formulation) + + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureSat ! saturated value of soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureWilt ! wilting point soil moisture [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureFieldCap ! reference soil moisture (field capacity) [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMoistureDry ! dry soil moisture threshold [m3/m3] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatDiffusivitySat ! saturated soil hydraulic diffusivity [m2/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilWatConductivitySat ! saturated soil hydraulic conductivity [m/s] + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilExpCoeffB ! soil exponent B paramete + real(kind=kind_noahmp), allocatable, dimension(:) :: SoilMatPotentialSat ! saturated soil matric potential [m] + + end type parameter_type + + +!=== define water type that includes 3 subtypes (flux,state,parameter) + type, public :: water_type + + type(flux_type) :: flux + type(state_type) :: state + type(parameter_type) :: param + + end type water_type + +end module WaterVarType diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/CheckNanMod.F90 b/src/core_atmosphere/physics/physics_noahmp/utility/CheckNanMod.F90 new file mode 100644 index 0000000000..54bb631d30 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/CheckNanMod.F90 @@ -0,0 +1,26 @@ +module CheckNanMod + +!!! Check NaN values + + use Machine, only : kind_noahmp + + implicit none + +contains + + subroutine CheckRealNaN(NumIn, OutVal) + +! ------------------------ Code history ----------------------------------- +! Original Noah-MP subroutine: embedded in NOAHMP_SFLX +! Original code: P. Valayamkunnath (2021) +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + real(kind=kind_noahmp), intent(in) :: NumIn + logical , intent(out) :: OutVal + + OutVal = (NumIn /= NumIn) + + end subroutine CheckRealNaN + +end module CheckNanMod diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/ErrorHandleMod.F90 b/src/core_atmosphere/physics/physics_noahmp/utility/ErrorHandleMod.F90 new file mode 100644 index 0000000000..74466efa3c --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/ErrorHandleMod.F90 @@ -0,0 +1,26 @@ +module ErrorHandleMod + +!!! define subroutines handling Noah-MP model errors + + use netcdf + + implicit none + +contains + + subroutine ErrorHandle(status) + +! ------------------------ Code history ----------------------------------- +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + integer, intent (in) :: status + + if(status /= nf90_noerr) then + print *, trim( nf90_strerror(status) ) + stop "Stopped" + endif + + end subroutine ErrorHandle + +end module ErrorHandleMod diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/Machine.F90 b/src/core_atmosphere/physics/physics_noahmp/utility/Machine.F90 new file mode 100644 index 0000000000..aafa838a77 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/Machine.F90 @@ -0,0 +1,22 @@ +module Machine +use mpas_kind_types,only: RKIND + +!!! define machine-related constants and parameters +!!! To define real data type precision, use "-DOUBLE_PREC" in CPPFLAG in user_build_options file +!!! By default, Noah-MP uses single precision + +! ------------------------ Code history ----------------------------------- +! Refactered code: C. He, P. Valayamkunnath, & refactor team (He et al. 2023) +! ------------------------------------------------------------------------- + + implicit none + save + private + + integer, public, parameter :: kind_noahmp = RKIND + integer, public, parameter :: undefined_int = -9999 ! undefined integer for variable initialization + real(kind=kind_noahmp), public, parameter :: undefined_real = -9999.0 ! undefined real for variable initializatin + integer, public, parameter :: undefined_int_neg = -9999 ! undefined integer negative for variable initialization + real(kind=kind_noahmp), public, parameter :: undefined_real_neg = -9999.0 ! undefined real negative for variable initializatin + +end module Machine diff --git a/src/core_atmosphere/physics/physics_noahmp/utility/Makefile b/src/core_atmosphere/physics/physics_noahmp/utility/Makefile new file mode 100644 index 0000000000..c5b5846554 --- /dev/null +++ b/src/core_atmosphere/physics/physics_noahmp/utility/Makefile @@ -0,0 +1,30 @@ +.SUFFIXES: .F90 .o + +.PHONY: utility utility_lib + +all: dummy utility + +dummy: + echo "****** compiling physics_noahmp/utility ******" + +OBJS = Machine.o \ + CheckNanMod.o + +utility: $(OBJS) + +utility_lib: + ar -ru ./../../libphys.a $(OBJS) + +# DEPENDENCIES: +CheckNanMod.o: \ + Machine.o + +clean: + $(RM) *.f90 *.o *.mod + @# Certain systems with intel compilers generate *.i files + @# This removes them during the clean process + $(RM) *.i + +.F90.o: + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F90 $(CPPINCLUDES) $(FCINCLUDES) -I../../../../framework + diff --git a/src/core_atmosphere/physics/physics_wrf/Makefile b/src/core_atmosphere/physics/physics_wrf/Makefile index cc9ee673b9..0d7d70ddbb 100644 --- a/src/core_atmosphere/physics/physics_wrf/Makefile +++ b/src/core_atmosphere/physics/physics_wrf/Makefile @@ -1,5 +1,7 @@ .SUFFIXES: .F .o +.PHONY: physics_wrf physics_wrf_lib + all: dummy physics_wrf dummy: @@ -7,6 +9,7 @@ dummy: OBJS = \ libmassv.o \ + module_bep_bem_helper.o \ module_bl_gwdo.o \ module_bl_mynn.o \ module_bl_ysu.o \ @@ -18,14 +21,15 @@ OBJS = \ module_cu_ntiedtke.o \ module_cu_kfeta.o \ module_mp_kessler.o \ - module_mp_radar.o \ module_mp_thompson.o \ + module_mp_thompson_aerosols.o \ module_mp_thompson_cldfra3.o \ module_mp_wsm6.o \ module_ra_cam.o \ module_ra_cam_support.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ + module_ra_rrtmg_sw_aerosols.o \ module_ra_rrtmg_vinterp.o \ module_sf_bem.o \ module_sf_bep.o \ @@ -34,25 +38,37 @@ OBJS = \ module_sf_mynn.o \ module_sf_noahdrv.o \ module_sf_noahlsm.o \ + module_sf_noahlsm_glacial_only.o \ + module_sf_noah_seaice.o \ + module_sf_noah_seaice_drv.o \ module_sf_oml.o \ module_sf_sfclay.o \ - module_sf_urban.o + module_sf_sfclayrev.o \ + module_sf_urban.o \ + bl_mynn_post.o \ + bl_mynn_pre.o \ + cu_ntiedtke_post.o \ + cu_ntiedtke_pre.o \ + sf_mynn_pre.o \ + sf_sfclayrev_pre.o + physics_wrf: $(OBJS) + +physics_wrf_lib: 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 -module_mp_thompson.o: \ - module_mp_radar.o - -module_mp_wsm6.o: \ - module_mp_radar.o +module_cu_ntiedtke.o: \ + cu_ntiedtke_post.o \ + cu_ntiedtke_pre.o module_ra_cam.o: \ module_cam_support.o \ @@ -66,23 +82,37 @@ module_ra_rrtmg_sw.o: \ module_ra_rrtmg_vinterp.o module_sf_bep.o: \ + module_bep_bem_helper.o \ module_sf_urban.o module_sf_bep_bem.o: \ + module_bep_bem_helper.o \ module_sf_bem.o \ module_sf_urban.o module_sf_mynn.o: \ - module_bl_mynn.o \ - module_sf_sfclay.o + sf_mynn_pre.o + +module_sf_sfclayrev.o: \ + sf_sfclayrev_pre.o module_sf_noahdrv.o: \ module_sf_bem.o \ module_sf_bep.o \ module_sf_bep_bem.o \ module_sf_noahlsm.o \ + module_sf_noahlsm_glacial_only.o \ module_sf_urban.o +module_sf_noahlsm_glacial_only.o: \ + module_sf_noahlsm.o + +module_sf_noah_seaice_drv.o: \ + module_sf_noah_seaice.o + +module_sf_noah_seaice.o: \ + module_sf_noahlsm.o + clean: $(RM) *.f90 *.o *.mod @# Certain systems with intel compilers generate *.i files @@ -92,7 +122,7 @@ clean: .F.o: ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(COREDEF) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework -I../../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../../../framework -I../../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(COREDEF) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I.. -I../physics_mmm -I../../../framework -I../../../external/esmf_time_f90 endif 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..ffca583a89 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/bl_mynn_post.F @@ -0,0 +1,159 @@ +!================================================================================================================= + module bl_mynn_post + use ccpp_kind_types,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 + +!================================================================================================================= +!>\section arg_table_bl_mynn_post_run +!!\html\include bl_mynn_post_run.html +!! + 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..5b76969601 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/bl_mynn_pre.F @@ -0,0 +1,148 @@ +!================================================================================================================= + module bl_mynn_pre + use ccpp_kind_types,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/cu_ntiedtke_post.F b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_post.F new file mode 100644 index 0000000000..e08c87d9f5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_post.F @@ -0,0 +1,120 @@ +!================================================================================================================= + module cu_ntiedtke_post + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: cu_ntiedtke_post_init, & + cu_ntiedtke_post_finalize, & + cu_ntiedtke_post_run + + + contains + + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_post_init +!!\html\include cu_ntiedtke_post_init.html +!! + subroutine cu_ntiedtke_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 cu_ntiedtke_post_init + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_post_finalize +!!\html\include cu_ntiedtke_post_finalize.html +!! + subroutine cu_ntiedtke_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 cu_ntiedtke_post_finalize + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_post_run +!!\html\include cu_ntiedtke_post_run.html +!! + subroutine cu_ntiedtke_post_run(its,ite,kts,kte,stepcu,dt,exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf,rn,raincv, & + pratec,rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt + real(kind=kind_phys),intent(in),dimension(its:ite):: rn + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: exner,qv,qc,qi,t,u,v,qvf,qcf,qif,tf,uf,vf + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(its:ite):: raincv,pratec + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rqvcuten,rqccuten,rqicuten + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: rthcuten,rucuten,rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys):: delt,rdelt + +!----------------------------------------------------------------------------------------------------------------- + + delt = dt*stepcu + rdelt = 1./delt + + do i = its,ite + raincv(i) = rn(i)/stepcu + pratec(i) = rn(i)/(stepcu*dt) + enddo + + pp = 0 + do k = kts,kte + zz = kte - pp + do i = its,ite + rthcuten(i,k) = (tf(i,zz)-t(i,k))/exner(i,k)*rdelt + rqvcuten(i,k) = (qvf(i,zz)-qv(i,k))*rdelt + rqccuten(i,k) = (qcf(i,zz)-qc(i,k))*rdelt + rqicuten(i,k) = (qif(i,zz)-qi(i,k))*rdelt + rucuten(i,k) = (uf(i,zz)-u(i,k))*rdelt + rvcuten(i,k) = (vf(i,zz)-v(i,k))*rdelt + enddo + pp = pp + 1 + enddo + + errmsg = 'cu_ntiedtke_post_run OK' + errflg = 0 + + end subroutine cu_ntiedtke_post_run + +!================================================================================================================= + end module cu_ntiedtke_post +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_pre.F b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_pre.F new file mode 100644 index 0000000000..84d2d89a54 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/cu_ntiedtke_pre.F @@ -0,0 +1,187 @@ +!================================================================================================================= + module cu_ntiedtke_pre + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: cu_ntiedtke_pre_init, & + cu_ntiedtke_pre_finalize, & + cu_ntiedtke_pre_run + + + contains + + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_pre_init +!!\html\include cu_ntiedtke_pre_init.html +!! + subroutine cu_ntiedtke_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 cu_ntiedtke_pre_init + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_pre_finalize +!!\html\include cu_ntiedtke_pre_finalize.html +!! + subroutine cu_ntiedtke_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 cu_ntiedtke_pre_finalize + +!================================================================================================================= +!>\section arg_table_cu_ntiedtke_pre_run +!!\html\include cu_ntiedtke_pre_run.html +!! + subroutine cu_ntiedtke_pre_run(its,ite,kts,kte,im,kx,kx1,itimestep,stepcu,dt,grav,xland,dz,pres,presi, & + t,rho,qv,qc,qi,u,v,w,qvften,thften,qvftenz,thftenz,slimsk,delt,prsl,ghtl, & + tf,qvf,qcf,qif,uf,vf,prsi,ghti,omg,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + integer,intent(in):: itimestep + integer,intent(in):: stepcu + + real(kind=kind_phys),intent(in):: dt,grav + real(kind=kind_phys),intent(in),dimension(its:ite):: xland + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: dz,pres,t,rho,qv,qc,qi,u,v + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvften,thften + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte+1):: presi,w + +!--- inout arguments: + integer,intent(inout):: im,kx,kx1 + integer,intent(inout),dimension(its:ite):: slimsk + + real(kind=kind_phys),intent(inout):: delt + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: tf,qvf,qcf,qif,uf,vf + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: ghtl,omg,prsl + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),intent(inout),dimension(its:ite,kts:kte+1):: ghti,prsi + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,k,pp,zz + + real(kind=kind_phys),dimension(its:ite,kts:kte):: zl,dot + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: zi + +!----------------------------------------------------------------------------------------------------------------- + + im = ite-its+1 + kx = kte-kts+1 + kx1 = kx+1 + + delt = dt*stepcu + + do i = its,ite + slimsk(i) = (abs(xland(i)-2.)) + enddo + + k = kts + do i = its,ite + zi(i,k) = 0. + enddo + do k = kts,kte + do i = its,ite + zi(i,k+1) = zi(i,k)+dz(i,k) + enddo + enddo + do k = kts,kte + do i = its,ite + zl(i,k) = 0.5*(zi(i,k)+zi(i,k+1)) + dot(i,k) = -0.5*grav*rho(i,k)*(w(i,k)+w(i,k+1)) + enddo + enddo + + pp = 0 + do k = kts,kte+1 + zz = kte + 1 - pp + do i = its,ite + ghti(i,zz) = zi(i,k) + prsi(i,zz) = presi(i,k) + enddo + pp = pp + 1 + enddo + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + ghtl(i,zz) = zl(i,k) + omg(i,zz) = dot(i,k) + prsl(i,zz) = pres(i,k) + enddo + pp = pp + 1 + enddo + + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + tf(i,zz) = t(i,k) + qvf(i,zz) = qv(i,k) + qcf(i,zz) = qc(i,k) + qif(i,zz) = qi(i,k) + uf(i,zz) = u(i,k) + vf(i,zz) = v(i,k) + enddo + pp = pp + 1 + enddo + + if(itimestep == 1) then + do k = kts,kte + do i = its,ite + qvftenz(i,k) = 0. + thftenz(i,k) = 0. + enddo + enddo + else + pp = 0 + do k = kts,kte + zz = kte-pp + do i = its,ite + qvftenz(i,zz) = qvften(i,k) + thftenz(i,zz) = thften(i,k) + enddo + pp = pp + 1 + enddo + endif + + errmsg = 'cu_ntiedtke_pre_run OK' + errflg = 0 + + end subroutine cu_ntiedtke_pre_run + +!================================================================================================================= + end module cu_ntiedtke_pre +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/libmassv.F b/src/core_atmosphere/physics/physics_wrf/libmassv.F index 9037850dfc..d1477c35c6 100644 --- a/src/core_atmosphere/physics/physics_wrf/libmassv.F +++ b/src/core_atmosphere/physics/physics_wrf/libmassv.F @@ -1,9 +1,13 @@ ! IBM libmassv compatibility library ! +#define R4KIND selected_real_kind(6) +#define R8KIND selected_real_kind(12) #ifndef NATIVE_MASSV subroutine vdiv(z,x,y,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=x(j)/y(j) 10 continue @@ -11,7 +15,9 @@ subroutine vdiv(z,x,y,n) end subroutine vsdiv(z,x,y,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=x(j)/y(j) 10 continue @@ -19,7 +25,9 @@ subroutine vsdiv(z,x,y,n) end subroutine vexp(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=exp(x(j)) 10 continue @@ -27,7 +35,9 @@ subroutine vexp(y,x,n) end subroutine vsexp(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=exp(x(j)) 10 continue @@ -35,7 +45,9 @@ subroutine vsexp(y,x,n) end subroutine vlog(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log(x(j)) 10 continue @@ -43,7 +55,9 @@ subroutine vlog(y,x,n) end subroutine vslog(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log(x(j)) 10 continue @@ -51,7 +65,9 @@ subroutine vslog(y,x,n) end subroutine vrec(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.d0/x(j) 10 continue @@ -59,7 +75,9 @@ subroutine vrec(y,x,n) end subroutine vsrec(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.e0/x(j) 10 continue @@ -67,7 +85,9 @@ subroutine vsrec(y,x,n) end subroutine vrsqrt(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.d0/sqrt(x(j)) 10 continue @@ -75,7 +95,9 @@ subroutine vrsqrt(y,x,n) end subroutine vsrsqrt(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=1.e0/sqrt(x(j)) 10 continue @@ -83,7 +105,9 @@ subroutine vsrsqrt(y,x,n) end subroutine vsincos(x,y,z,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n x(j)=sin(z(j)) y(j)=cos(z(j)) @@ -92,7 +116,9 @@ subroutine vsincos(x,y,z,n) end subroutine vssincos(x,y,z,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n x(j)=sin(z(j)) y(j)=cos(z(j)) @@ -101,7 +127,9 @@ subroutine vssincos(x,y,z,n) end subroutine vsqrt(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sqrt(x(j)) 10 continue @@ -109,7 +137,9 @@ subroutine vsqrt(y,x,n) end subroutine vssqrt(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sqrt(x(j)) 10 continue @@ -117,7 +147,9 @@ subroutine vssqrt(y,x,n) end subroutine vtan(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tan(x(j)) 10 continue @@ -125,7 +157,9 @@ subroutine vtan(y,x,n) end subroutine vstan(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tan(x(j)) 10 continue @@ -133,7 +167,9 @@ subroutine vstan(y,x,n) end subroutine vatan2(z,y,x,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=atan2(y(j),x(j)) 10 continue @@ -141,7 +177,9 @@ subroutine vatan2(z,y,x,n) end subroutine vsatan2(z,y,x,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=atan2(y(j),x(j)) 10 continue @@ -149,7 +187,9 @@ subroutine vsatan2(z,y,x,n) end subroutine vasin(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=asin(x(j)) 10 continue @@ -157,7 +197,9 @@ subroutine vasin(y,x,n) end subroutine vsin(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sin(x(j)) 10 continue @@ -165,7 +207,9 @@ subroutine vsin(y,x,n) end subroutine vssin(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sin(x(j)) 10 continue @@ -173,7 +217,9 @@ subroutine vssin(y,x,n) end subroutine vacos(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=acos(x(j)) 10 continue @@ -181,7 +227,9 @@ subroutine vacos(y,x,n) end subroutine vcos(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cos(x(j)) 10 continue @@ -189,7 +237,9 @@ subroutine vcos(y,x,n) end subroutine vscos(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cos(x(j)) 10 continue @@ -197,25 +247,31 @@ subroutine vscos(y,x,n) end subroutine vcosisin(y,x,n) - complex*16 y(*) - real*8 x(*) + complex(kind=R8KIND) y(*) + real(kind=R8KIND) x(*) + integer n + integer j do 10 j=1,n - y(j)=dcmplx(cos(x(j)),sin(x(j))) + y(j)=cmplx(cos(x(j)),sin(x(j)),kind=R8KIND) 10 continue return end subroutine vscosisin(y,x,n) - complex*8 y(*) - real*4 x(*) + complex(kind=R4KIND) y(*) + real(kind=R4KIND) x(*) + integer n + integer j do 10 j=1,n - y(j)= cmplx(cos(x(j)),sin(x(j))) + y(j)= cmplx(cos(x(j)),sin(x(j)),kind=R4KIND) 10 continue return end subroutine vdint(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n ! y(j)=dint(x(j)) y(j)=int(x(j)) @@ -224,7 +280,9 @@ subroutine vdint(y,x,n) end subroutine vdnint(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n ! y(j)=dnint(x(j)) y(j)=nint(x(j)) @@ -233,7 +291,9 @@ subroutine vdnint(y,x,n) end subroutine vlog10(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log10(x(j)) 10 continue @@ -241,10 +301,10 @@ subroutine vlog10(y,x,n) end ! subroutine vlog1p(y,x,n) -! real*8 x(*),y(*) +! real(kind=R8KIND) x(*),y(*) ! interface -! real*8 function log1p(%val(x)) -! real*8 x +! real(kind=R8KIND) function log1p(%val(x)) +! real(kind=R8KIND) x ! end function log1p ! end interface ! do 10 j=1,n @@ -254,7 +314,9 @@ subroutine vlog10(y,x,n) ! end subroutine vcosh(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cosh(x(j)) 10 continue @@ -262,7 +324,9 @@ subroutine vcosh(y,x,n) end subroutine vsinh(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sinh(x(j)) 10 continue @@ -270,7 +334,9 @@ subroutine vsinh(y,x,n) end subroutine vtanh(y,x,n) - real*8 x(*),y(*) + real(kind=R8KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tanh(x(j)) 10 continue @@ -278,10 +344,10 @@ subroutine vtanh(y,x,n) end ! subroutine vexpm1(y,x,n) -! real*8 x(*),y(*) +! real(kind=R8KIND) x(*),y(*) ! interface -! real*8 function expm1(%val(x)) -! real*8 x +! real(kind=R8KIND) function expm1(%val(x)) +! real(kind=R8KIND) x ! end function expm1 ! end interface ! do 10 j=1,n @@ -292,7 +358,9 @@ subroutine vtanh(y,x,n) subroutine vsasin(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=asin(x(j)) 10 continue @@ -300,7 +368,9 @@ subroutine vsasin(y,x,n) end subroutine vsacos(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n #if defined (G95) ! no reason why g95 should fail - oh well, we don't use this routine anyways @@ -313,7 +383,9 @@ subroutine vsacos(y,x,n) end subroutine vscosh(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=cosh(x(j)) 10 continue @@ -321,10 +393,10 @@ subroutine vscosh(y,x,n) end ! subroutine vsexpm1(y,x,n) -! real*4 x(*),y(*) +! real(kind=R4KIND) x(*),y(*) ! interface -! real*8 function expm1(%val(x)) -! real*8 x +! real(kind=R8KIND) function expm1(%val(x)) +! real(kind=R8KIND) x ! end function expm1 ! end interface ! do 10 j=1,n @@ -334,7 +406,9 @@ subroutine vscosh(y,x,n) ! end subroutine vslog10(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=log10(x(j)) 10 continue @@ -342,10 +416,10 @@ subroutine vslog10(y,x,n) end ! subroutine vslog1p(y,x,n) -! real*4 x(*),y(*) +! real(kind=R4KIND) x(*),y(*) ! interface -! real*8 function log1p(%val(x)) -! real*8 x +! real(kind=R8KIND) function log1p(%val(x)) +! real(kind=R8KIND) x ! end function log1p ! end interface ! do 10 j=1,n @@ -356,7 +430,9 @@ subroutine vslog10(y,x,n) subroutine vssinh(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=sinh(x(j)) 10 continue @@ -364,7 +440,9 @@ subroutine vssinh(y,x,n) end subroutine vstanh(y,x,n) - real*4 x(*),y(*) + real(kind=R4KIND) x(*),y(*) + integer n + integer j do 10 j=1,n y(j)=tanh(x(j)) 10 continue @@ -373,7 +451,9 @@ subroutine vstanh(y,x,n) #endif subroutine vspow(z,y,x,n) - real*4 x(*),y(*),z(*) + real(kind=R4KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=y(j)**x(j) 10 continue @@ -381,7 +461,9 @@ subroutine vspow(z,y,x,n) end subroutine vpow(z,y,x,n) - real*8 x(*),y(*),z(*) + real(kind=R8KIND) x(*),y(*),z(*) + integer n + integer j do 10 j=1,n z(j)=y(j)**x(j) 10 continue diff --git a/src/core_atmosphere/physics/physics_wrf/module_bep_bem_helper.F b/src/core_atmosphere/physics/physics_wrf/module_bep_bem_helper.F new file mode 100644 index 0000000000..ac29b7bf9a --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_bep_bem_helper.F @@ -0,0 +1,4 @@ +MODULE module_bep_bem_helper + integer, save :: nurbm ! Maximum number of urban classes +CONTAINS +END MODULE module_bep_bem_helper diff --git a/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F b/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F index ac7c660f22..ae95ed5d62 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_gwdo.F @@ -1,752 +1,241 @@ -!================================================================================================== -! copied for implementation in MPAS from WRF version 3.6.1. +!================================================================================================================= + module module_bl_gwdo + use mpas_kind_types,only: kind_phys => RKIND + use bl_gwdo -! modifications made to sourcecode: -! * used preprocessing option to define the variable dx as a function of the horizontal grid. -! Laura D. Fowler (laura@ucar.edu) / 2014-09-25. + implicit none + private + public:: gwdo -!================================================================================================== -! WRf:model_layer:physics -! -! -! -! -! -module module_bl_gwdo -contains -! -!------------------------------------------------------------------- -! - subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & - rublten,rvblten, & - dtaux3d,dtauy3d,dusfcg,dvsfcg, & - var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & - znu,znw,mut,p_top, & - cp,g,rd,rv,ep1,pi, & - dt,dx,kpbl2d,itimestep, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------ -! -!-- u3d 3d u-velocity interpolated to theta points (m/s) -!-- v3d 3d v-velocity interpolated to theta points (m/s) -!-- t3d temperature (k) -!-- qv3d 3d water vapor mixing ratio (kg/kg) -!-- p3d 3d pressure (pa) -!-- p3di 3d pressure (pa) at interface level -!-- pi3d 3d exner function (dimensionless) -!-- rublten u tendency due to -! pbl parameterization (m/s/s) -!-- rvblten v tendency due to -!-- cp heat capacity at constant pressure for dry air (j/kg/k) -!-- g acceleration due to gravity (m/s^2) -!-- rd gas constant for dry air (j/kg/k) -!-- z height above sea level (m) -!-- rv gas constant for water vapor (j/kg/k) -!-- dt time step (s) -!-- dx model grid interval (m) -!-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- kds start index for k in domain -!-- kde end index for k in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- kms start index for k in memory -!-- kme end index for k in memory -!-- its start index for i in tile -!-- ite end index for i in tile -!-- jts start index for j in tile -!-- jte end index for j in tile -!-- kts start index for k in tile -!-- kte end index for k in tile -!------------------------------------------------------------------- -! - 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 -! -!MPAS specific (Laura D. Fowler 2013-02-12): -#if defined(mpas) - real, intent(in ) :: dt,cp,g,rd,rv,ep1,pi - real, intent(in), dimension(ims:ime,jms:jme):: dx -#else - real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi -#endif -!MPAS specific end. -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: qv3d, & - p3d, & - pi3d, & - t3d, & - z - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: p3di -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & - rvblten - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: dtaux3d, & - dtauy3d -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: u3d, & - v3d -! - integer, dimension( ims:ime, jms:jme ) , & - intent(in ) :: kpbl2d - real, dimension( ims:ime, jms:jme ) , & - intent(inout ) :: dusfcg, & - dvsfcg -! - real, dimension( ims:ime, jms:jme ) , & - intent(in ) :: var2d, & - oc12d, & - oa2d1,oa2d2,oa2d3,oa2d4, & - ol2d1,ol2d2,ol2d3,ol2d4 -! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(in ) :: mut -! - real, dimension( kms:kme ) , & - optional , & - intent(in ) :: znu, & - znw -! - real, optional, intent(in ) :: p_top -! -!local -! - real, dimension( its:ite, kts:kte ) :: delprsi, & - pdh - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite, 4 ) :: oa4, & - ol4 - integer :: i,j,k,kdt -! - do j = jts,jte - if(present(mut))then -! For ARW we will replace p and p8w with dry hydrostatic pressure - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top - pdhi(i,k) = mut(i,j)*znw(k) + p_top - enddo - enddo - else - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo - endif -! - do k = kts,kte - do i = its,ite - delprsi(i,k) = pdhi(i,k)-pdhi(i,k+1) - enddo - enddo - do i = its,ite - oa4(i,1) = oa2d1(i,j) - oa4(i,2) = oa2d2(i,j) - oa4(i,3) = oa2d3(i,j) - oa4(i,4) = oa2d4(i,j) - ol4(i,1) = ol2d1(i,j) - ol4(i,2) = ol2d2(i,j) - ol4(i,3) = ol2d3(i,j) - ol4(i,4) = ol2d4(i,j) - enddo - call gwdo2d(dudt=rublten(ims,kms,j),dvdt=rvblten(ims,kms,j) & - ,dtaux2d=dtaux3d(ims,kms,j),dtauy2d=dtauy3d(ims,kms,j) & - ,u1=u3d(ims,kms,j),v1=v3d(ims,kms,j) & - ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) & - ,prsi=pdhi(its,kts),del=delprsi(its,kts) & - ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) & - ,zl=z(ims,kms,j),rcl=1.0 & - ,dusfc=dusfcg(ims,j),dvsfc=dvsfcg(ims,j) & - ,var=var2d(ims,j),oc1=oc12d(ims,j) & - ,oa4=oa4,ol4=ol4 & - ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi & -!MPAS specific (Laura D. Fowler 2013-02-12): -#if defined(mpas) - ,dxmeter=dx(ims,j),deltim=dt & -#else - ,dxmeter=dx,deltim=dt & -#endif -!MPAS specific end. - ,kpbl=kpbl2d(ims,j),kdt=itimestep,lat=j & - ,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 ) - enddo -! -! - end subroutine gwdo -! -!------------------------------------------------------------------- -! -! -! -! - subroutine gwdo2d(dudt,dvdt,dtaux2d,dtauy2d, & - u1,v1,t1,q1, & - prsi,del,prsl,prslk,zl,rcl, & - var,oc1,oa4,ol4,dusfc,dvsfc, & - g,cp,rd,rv,fv,pi,dxmeter,deltim,kpbl,kdt,lat, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte) -!------------------------------------------------------------------- -! -! this code handles the time tendencies of u v due to the effect of mountain -! induced gravity wave drag from sub-grid scale orography. this routine -! not only treats the traditional upper-level wave breaking due to mountain -! variance (alpert 1988), but also the enhanced lower-tropospheric wave -! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). -! thus, in addition to the terrain height data in a model grid gox, -! additional 10-2d topographic statistics files are needed, including -! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) -! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography -! hong (1999). the current scheme was implmented as in hong et al.(2008) -! -! coded by song-you hong and young-joon kim and implemented by song-you hong -! -! references: -! hong et al. (2008), wea. and forecasting -! kim and arakawa (1995), j. atmos. sci. -! alpet et al. (1988), NWP conference. -! hong (1999), NCEP office note 424. -! -! notice : comparible or lower resolution orography files than model resolution -! are desirable in preprocess (wps) to prevent weakening of the drag -!------------------------------------------------------------------- -! -! input -! dudt (ims:ime,kms:kme) non-lin tendency for u wind component -! dvdt (ims:ime,kms:kme) non-lin tendency for v wind component -! u1(ims:ime,kms:kme) zonal wind / sqrt(rcl) m/sec at t0-dt -! v1(ims:ime,kms:kme) meridional wind / sqrt(rcl) m/sec at t0-dt -! t1(ims:ime,kms:kme) temperature deg k at t0-dt -! q1(ims:ime,kms:kme) specific humidity at t0-dt -! -! rcl a scaling factor = reciprocal of square of cos(lat) -! for mrf gsm. rcl=1 if u1 and v1 are wind components. -! deltim time step secs -! del(kts:kte) positive increment of pressure across layer (pa) -! -! output -! dudt, dvdt wind tendency due to gwdo -! -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - integer :: kdt,lat,latd,lond, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte -! -!MPAS specific (Laura D. Fowler 2013-02-12): -#if defined(mpas) - real :: g,rd,rv,fv,cp,pi,deltim,rcl - real, dimension(ims:ime):: dxmeter -#else - real :: g,rd,rv,fv,cp,pi,dxmeter,deltim,rcl -#endif -!MPAS specific end. - - real :: dudt(ims:ime,kms:kme),dvdt(ims:ime,kms:kme), & - dtaux2d(ims:ime,kms:kme),dtauy2d(ims:ime,kms:kme), & - u1(ims:ime,kms:kme),v1(ims:ime,kms:kme), & - t1(ims:ime,kms:kme),q1(ims:ime,kms:kme), & - zl(ims:ime,kms:kme),prslk(ims:ime,kms:kme) - real :: prsl(its:ite,kts:kte),prsi(its:ite,kts:kte+1), & - del(its:ite,kts:kte) - real :: oa4(its:ite,4),ol4(its:ite,4) -! - integer :: kpbl(ims:ime) - real :: var(ims:ime),oc1(ims:ime), & - dusfc(ims:ime),dvsfc(ims:ime) -! critical richardson number for wave breaking : ! larger drag with larger value -! - real,parameter :: ric = 0.25 -! - real,parameter :: dw2min = 1. - real,parameter :: rimin = -100. - real,parameter :: bnv2min = 1.0e-5 - real,parameter :: efmin = 0.0 - real,parameter :: efmax = 10.0 - real,parameter :: xl = 4.0e4 - real,parameter :: critac = 1.0e-5 - real,parameter :: gmax = 1. - real,parameter :: veleps = 1.0 - real,parameter :: factop = 0.5 - real,parameter :: frc = 1.0 - real,parameter :: ce = 0.8 - real,parameter :: cg = 0.5 -! -! local variables -! - integer :: i,k,lcap,lcapp1,nwd,idir,kpblmin,kpblmax, & - klcap,kp1,ikount,kk -! -!MPAS specific (Laura D. Fowler 2013-02-12): -#if defined(mpas) - real :: rcs,rclcs,csg,fdir,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,coefm,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & - temv,dtaux,dtauy - real, dimension(its:ite):: cleff -#else - real :: rcs,rclcs,csg,fdir,cleff,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,coefm,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & - temv,dtaux,dtauy -#endif -! - logical :: ldrag(its:ite),icrilv(its:ite), & - flag(its:ite),kloop1(its:ite) -! - real :: taub(its:ite),taup(its:ite,kts:kte+1), & - xn(its:ite),yn(its:ite), & - ubar(its:ite),vbar(its:ite), & - fr(its:ite),ulow(its:ite), & - rulow(its:ite),bnv(its:ite), & - oa(its:ite),ol(its:ite), & - roll(its:ite),dtfac(its:ite), & - brvf(its:ite),xlinv(its:ite), & - delks(its:ite),delks1(its:ite), & - bnv2(its:ite,kts:kte),usqj(its:ite,kts:kte), & - taud(its:ite,kts:kte),ro(its:ite,kts:kte), & - vtk(its:ite,kts:kte),vtj(its:ite,kts:kte), & - zlowtop(its:ite),velco(its:ite,kts:kte-1) -! - integer :: kbl(its:ite),klowtop(its:ite), & - lowlv(its:ite) -! - logical :: iope - integer,parameter :: mdir=8 - integer :: nwdir(mdir) - data nwdir/6,7,5,8,2,3,1,4/ -! -! initialize local variables -! - kbl=0 ; klowtop=0 ; lowlv=0 -! -!---- constants -! - rcs = sqrt(rcl) - cs = 1. / sqrt(rcl) - csg = cs * g - lcap = kte - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi) -! -! -!!!!!!! cleff (subgrid mountain scale ) is highly tunable parameter -!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag -! -!MPAS specific (Laura D. Fowler 2013-02-13): -#if defined(mpas) - do i = its, ite - cleff(i) = max(dxmeter(i),50.e3) - enddo -#else - cleff = max(dxmeter,50.e3) -#endif -!MPAS specific end. -! -! initialize!! -! - dtaux = 0.0 - dtauy = 0.0 - do k = kts,kte - do i = its,ite - usqj(i,k) = 0.0 - bnv2(i,k) = 0.0 - vtj(i,k) = 0.0 - vtk(i,k) = 0.0 - taup(i,k) = 0.0 - taud(i,k) = 0.0 - dtaux2d(i,k)= 0.0 - dtauy2d(i,k)= 0.0 - enddo - enddo - do i = its,ite - taup(i,kte+1) = 0.0 - xlinv(i) = 1.0/xl - enddo -! - do k = kts,kte - do i = its,ite - vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) - vtk(i,k) = vtj(i,k) / prslk(i,k) - ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 - enddo - enddo -! - do i = its,ite - zlowtop(i) = 2. * var(i) - enddo -! -!--- determine new reference level > 2*var -! - do i = its,ite - kloop1(i) = .true. - enddo - do k = kts+1,kte - do i = its,ite - if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then - klowtop(i) = k+1 - kloop1(i) = .false. - endif - enddo - enddo -! - kpblmax = 2 - do i = its,ite - kbl(i) = max(2, kpbl(i)) - kbl(i) = max(kbl(i), klowtop(i)) - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - taup(i,1) = 0.0 - oa(i) = 0.0 - kpblmax = max(kpblmax,kbl(i)) - flag(i) = .true. - lowlv(i) = 2 - enddo - kpblmax = min(kpblmax+1,kte-1) -! -! compute low level averages within pbl -! - do k = kts,kpblmax - do i = its,ite - if (k.lt.kbl(i)) then - rcsks = rcs * del(i,k) * delks(i) - ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean - endif - enddo - enddo -! -! figure out low-level horizontal wind direction -! -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se -! - do i = its,ite - wdir = atan2(ubar(i),vbar(i)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) - ol(i) = ol4(i,mod(nwd-1,4)+1) - enddo -! - kpblmax = 2 - kpblmin = kte - do i = its,ite - if (oa(i).le.0.0) kbl(i) = kpbl(i) + 1 - kpblmax = max(kpblmax,kbl(i)) - kpblmin = min(kpblmin, kbl(i)) - enddo - kpblmax = min(kpblmax+1,kte-1) -! - do i = its,ite - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) - enddo -! -!--- saving richardson number in usqj for migwdi -! - do k = kts,kte-1 - do i = its,ite - ti = 2.0 / (t1(i,k)+t1(i,k+1)) - rdz = 1./(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = rcl*(tem1*tem1 + tem2*tem2) - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = 2*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - bnv2(i,k) = max( bnv2(i,k), bnv2min ) - enddo - enddo -! -!-----initialize arrays -! - do i = its,ite - xn(i) = 0.0 - yn(i) = 0.0 - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - taub (i) = 0.0 - ulow (i) = 0.0 - dtfac(i) = 1.0 - ldrag(i) = .false. - icrilv(i) = .false. ! initialize critical level control vector - enddo -! -!---- compute low level averages -!---- (u,v)*cos(lat) use uv=(u1,v1) which is wind at t0-1 -!---- use rcs=1/cos(lat) to get wind field -! - do k = 1,kpblmax - do i = its,ite - if (k .lt. kbl(i)) then - rdelks = del(i,k) * delks(i) - rcsks = rcs * rdelks - ubar(i) = ubar(i) + rcsks * u1(i,k) ! u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! v mean - roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean - endif - enddo - enddo -! -!----compute the "low level" or 1/3 wind magnitude (m/s) -! - do i = its,ite - ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) - rulow(i) = 1./ulow(i) - enddo -! - do k = kts,kte-1 - do i = its,ite - velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) - if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then - velco(i,k) = veleps - endif - enddo - enddo -! -! no drag when critical level in the base layer -! - do i = its,ite - ldrag(i) = velco(i,1).le.0. - enddo -! - do k = kts+1,kpblmax-1 - do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. - enddo - enddo -! -! no drag when bnv2.lt.0 -! - do k = kts,kpblmax-1 - do i = its,ite - if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0. - enddo - enddo -! -!-----the low level weighted average ri is stored in usqj(1,1; im) -!-----the low level weighted average n**2 is stored in bnv2(1,1; im) -!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 -!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / -! - do i = its,ite - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) - enddo -! - do k = kts+1,kpblmax-1 - do i = its,ite - if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) - bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks - usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks - endif - enddo - enddo -! - do i = its,ite - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 - ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 - ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 - enddo -! -! ----- set all ri low level values to the low level value -! - do k = kts+1,kpblmax-1 - do i = its,ite - if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) - enddo - enddo -! - do i = its,ite - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * var(i) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) - endif - enddo -! -! compute the base level stress and store it in taub -! calculate enhancement factor, number of mountains & aspect -! ratio const. use simplified relationship between standard -! deviation & critical hgt -! - do i = its,ite - if (.not. ldrag(i)) then - efact = (oa(i) + 2.) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + ol(i)) ** (oa(i)+1.) -!MPAS specific (Laura D. Fowler 2013-02-12): -#if defined(mpas) - xlinv(i) = coefm / cleff(i) -#else - xlinv(i) = coefm / cleff -#endif - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else - taub(i) = 0.0 - xn(i) = 0.0 - yn(i) = 0.0 - endif - enddo -! -! now compute vertical structure of the stress. -! -!----set up bottom values of stress -! - do k = kts,kpblmax - do i = its,ite - if (k .le. kbl(i)) taup(i,k) = taub(i) - enddo - enddo -! - do k = kpblmin, kte-1 ! vertical level k loop! - kp1 = k + 1 - do i = its,ite -! -!-----unstablelayer if ri < ric -!-----unstable layer if upper air vel comp along surf vel <=0 (crit lay) -!---- at (u-c)=0. crit layer exists and bit vector should be set (.le.) -! - if (k .ge. kbl(i)) then - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & - .or. (velco(i,k) .le. 0.0) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency - endif - enddo -! - do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then - if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then - temv = 1.0 / velco(i,k) - tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv -! -! rim is the minimum-richardson number by shutts (1985) -! - tem2 = sqrt(usqj(i,k)) - tem = 1. + tem2 * fro - rim = usqj(i,k) * (1.-fro) / (tem * tem) -! -! check stability to employ the 'saturation hypothesis' -! of lindzen (1981) except at tropospheric downstream regions -! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa(i) .le. 0. .or. kp1 .ge. lowlv(i) )) then - temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) - taup(i,kp1) = tem1 * hd * hd - endif - else ! no wavebreaking! - taup(i,kp1) = taup(i,k) - endif - endif - endif - enddo - enddo -! - if(lcap.lt.kte) then - do klcap = lcapp1,kte + contains + + +!================================================================================================================= + subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & + rublten,rvblten, & + dtaux3d,dtauy3d,dusfcg,dvsfcg, & + var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & + sina,cosa,znu,znw,p_top, & + cp,g,rd,rv,ep1,pi, & + dt,dx,kpbl2d,itimestep, & + 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 temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- p3d 3d pressure (pa) +!-- p3di 3d pressure (pa) at interface level +!-- pi3d 3d exner function (dimensionless) +!-- rublten u tendency due to pbl parameterization (m/s/s) +!-- rvblten v tendency due to pbl parameterization (m/s/s) +!-- sina sine rotation angle +!-- cosa cosine rotation angle +!-- znu eta values (sigma values) +!-- cp heat capacity at constant pressure for dry air (j/kg/k) +!-- g acceleration due to gravity (m/s^2) +!-- rd gas constant for dry air (j/kg/k) +!-- z height above sea level (m) +!-- rv gas constant for water vapor (j/kg/k) +!-- dt time step (s) +!-- dx model grid interval (m) +!-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!================================================================================================================= + +!--- 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),dimension(ims:ime,jms:jme):: kpbl2d + + real(kind=kind_phys),intent(in):: dt,cp,g,rd,rv,ep1,pi + real(kind=kind_phys),intent(in),optional:: p_top + + real(kind=kind_phys),intent(in),dimension(kms:kme),optional:: & + znu, & + znw + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, & + var2d, & + oc12d, & + oa2d1,oa2d2,oa2d3,oa2d4, & + ol2d1,ol2d2,ol2d3,ol2d4, & + sina,cosa + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + qv3d, & + p3d, & + pi3d, & + t3d, & + u3d, & + v3d, & + z + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + p3di + +!--- output arguments: + character(len=*),intent(out):: errmsg + + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + dusfcg, & + dvsfcg + + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + dtaux3d, & + dtauy3d + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + rublten, & + rvblten + +!--- local variables and arrays: + integer:: i,j,k + + real(kind=kind_phys),dimension(its:ite):: & + var2d_hv,oc12d_hv,dx_hv,sina_hv,cosa_hv + real(kind=kind_phys),dimension(its:ite):: & + oa2d1_hv,oa2d2_hv,oa2d3_hv,oa2d4_hv,ol2d1_hv,ol2d2_hv,ol2d3_hv,ol2d4_hv + real(kind=kind_phys),dimension(its:ite):: & + dusfcg_hv,dvsfcg_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + u3d_hv,v3d_hv,t3d_hv,qv3d_hv,pi3d_hv,p3d_hv,z_hv + + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + rublten_hv,rvblten_hv,dtaux3d_hv,dtauy3d_hv + + real(kind=kind_phys),dimension(its:ite,kms:kme):: & + p3di_hv + +!----------------------------------------------------------------------------------------------------------------- + +! Outer j-loop. Allows consistency between WRF and MPAS in the driver. + + do j = jts,jte + + ! All variables for gwdo2d are tile-sized and have only a single + ! horizontal dimension. The _hv suffix refers to "horizontal vertical", + ! a reminder that there is a single horizontal index. Yes, we know that + ! variables that have only a horizontal index are not *really* _hv. + + ! All of the following 3d and 2d variables are declared intent(in) in the + ! gwdo2d subroutine, so there is no need to put the updated values back + ! from the temporary arrays back into the original arrays. + + ! Variables that are INTENT(IN) or INTENT(INOUT) + + ! 3d, interface levels: + do k = kts,kte+1 do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + p3di_hv(i,k) = p3di(i,k,j) enddo - enddo - endif -! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy -! - do k = kts,kte - do i = its,ite - taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) - enddo - enddo -! -!------limit de-acceleration (momentum deposition ) at top to 1/2 value -!------the idea is some stuff must go out the 'top' -! - do klcap = lcap,kte - do i = its,ite - taud(i,klcap) = taud(i,klcap) * factop - enddo - enddo -! -!------if the gravity wave drag would force a critical line -!------in the lower ksmm1 layers during the next deltim timestep, -!------then only apply drag until that critical line is reached. -! - do k = kts,kpblmax-1 - do i = its,ite - if (k .le. kbl(i)) then - if(taud(i,k).ne.0.) & - dtfac(i) = min(dtfac(i),abs(velco(i,k) & - /(deltim*rcs*taud(i,k)))) - endif - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - enddo -! - do k = kts,kte - do i = its,ite - taud(i,k) = taud(i,k) * dtfac(i) - dtaux = taud(i,k) * xn(i) - dtauy = taud(i,k) * yn(i) - dtaux2d(i,k) = dtaux - dtauy2d(i,k) = dtauy - dudt(i,k) = dtaux + dudt(i,k) - dvdt(i,k) = dtauy + dvdt(i,k) - dusfc(i) = dusfc(i) + dtaux * del(i,k) - dvsfc(i) = dvsfc(i) + dtauy * del(i,k) - enddo - enddo -! - do i = its,ite - dusfc(i) = (-1./g*rcs) * dusfc(i) - dvsfc(i) = (-1./g*rcs) * dvsfc(i) - enddo -! - return - end subroutine gwdo2d -!------------------------------------------------------------------- + enddo + + ! 3d, layers: + do k = kts,kte + do i = its,ite + rublten_hv(i,k) = rublten(i,k,j) + rvblten_hv(i,k) = rvblten(i,k,j) + u3d_hv(i,k) = u3d(i,k,j) + v3d_hv(i,k) = v3d(i,k,j) + t3d_hv(i,k) = t3d(i,k,j) + qv3d_hv(i,k) = qv3d(i,k,j) + p3d_hv(i,k) = p3d(i,k,j) + pi3d_hv(i,k) = pi3d(i,k,j) + z_hv(i,k) = z(i,k,j) + enddo + enddo + + ! 2d: + do i = its,ite + dx_hv(i) = dx(i,j) + var2d_hv(i) = var2d(i,j) + oc12d_hv(i) = oc12d(i,j) + sina_hv(i) = sina(i,j) + cosa_hv(i) = cosa(i,j) + oa2d1_hv(i) = oa2d1(i,j) + oa2d2_hv(i) = oa2d2(i,j) + oa2d3_hv(i) = oa2d3(i,j) + oa2d4_hv(i) = oa2d4(i,j) + ol2d1_hv(i) = ol2d1(i,j) + ol2d2_hv(i) = ol2d2(i,j) + ol2d3_hv(i) = ol2d3(i,j) + ol2d4_hv(i) = ol2d4(i,j) + enddo + + call bl_gwdo_run(sina=sina_hv,cosa=cosa_hv & + ,rublten=rublten_hv,rvblten=rvblten_hv & + ,dtaux3d=dtaux3d_hv,dtauy3d=dtauy3d_hv & + ,dusfcg=dusfcg_hv,dvsfcg=dvsfcg_hv & + ,uproj=u3d_hv,vproj=v3d_hv & + ,t1=t3d_hv,q1=qv3d_hv & + ,prsi=p3di_hv & + ,prsl=p3d_hv,prslk=pi3d_hv & + ,zl=z_hv & + ,var=var2d_hv,oc1=oc12d_hv & + ,oa2d1=oa2d1_hv, oa2d2=oa2d2_hv & + ,oa2d3=oa2d3_hv, oa2d4=oa2d4_hv & + ,ol2d1=ol2d1_hv, ol2d2=ol2d2_hv & + ,ol2d3=ol2d3_hv, ol2d4=ol2d4_hv & + ,g_=g,cp_=cp,rd_=rd,rv_=rv,fv_=ep1,pi_=pi & + ,dxmeter=dx_hv,deltim=dt & + ,its=its,ite=ite,kte=kte,kme=kte+1 & + ,errmsg=errmsg,errflg=errflg) + + ! Variables that are INTENT(OUT) or INTENT(INOUT): + + ! 3d, layers: + do k = kts,kte + do i = its,ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) + dtaux3d(i,k,j) = dtaux3d_hv(i,k) + dtauy3d(i,k,j) = dtauy3d_hv(i,k) + enddo + enddo + + ! 2d: + do i = its,ite + dusfcg(i,j) = dusfcg_hv(i) + dvsfcg(i,j) = dvsfcg_hv(i) + enddo + + enddo ! Outer J-loop + + end subroutine gwdo + +!================================================================================================================= end module module_bl_gwdo +!================================================================================================================= 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_bl_ysu.F b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F index 9061651398..cf7340aaf8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F +++ b/src/core_atmosphere/physics/physics_wrf/module_bl_ysu.F @@ -1,54 +1,47 @@ +#define NEED_B4B_DURING_CCPP_TESTING 1 !================================================================================================================= -!module_bl_ysu.F was originally copied from ./phys/module_bl_ysu.F from WRF version 3.8.1. -!Laura D. Fowler (laura@ucar.edu) / 2016-10-26. + module module_bl_ysu + use mpas_kind_types,only: kind_phys => RKIND + use bl_ysu + + + implicit none + private + public:: ysu + + + contains -!modifications to sourcecode for MPAS: -! * calculated the dry hydrostatic pressure using the dry air density. -! * added outputs of the vertical diffusivity coefficients. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-26. !================================================================================================================= -!WRF:model_layer:physics -! -! -! -! -! -! -! -module module_bl_ysu -contains -! -! -!------------------------------------------------------------------------------- -! - subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & + subroutine ysu(u3d,v3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & rublten,rvblten,rthblten, & - rqvblten,rqcblten,rqiblten,flag_qi, & + rqvblten,rqcblten,rqiblten,flag_qc,flag_qi, & cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & dz8w,psfc, & - znu,znw,mut,p_top, & znt,ust,hpbl,psim,psih, & xland,hfx,qfx,wspd,br, & dt,kpbl2d, & - exch_h, & + exch_h,exch_m, & wstar,delta, & u10,v10, & uoce,voce, & rthraten,ysu_topdown_pblmix, & ctopo,ctopo2, & + idiff,flag_bep,frc_urb2d, & + a_u_bep,a_v_bep,a_t_bep, & + a_q_bep, & + a_e_bep,b_u_bep,b_v_bep, & + b_t_bep,b_q_bep, & + b_e_bep,dlg_bep, & + dl_u_bep,sf_bep,vl_bep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - !optional - regime & -#if defined(mpas) - !MPAS specific optional arguments for additional diagnostics: - ,rho,kzhout,kzmout,kzqout & -#endif + errmsg,errflg & ) !------------------------------------------------------------------------------- - implicit none + implicit none !------------------------------------------------------------------------------- !-- u3d 3d u-velocity interpolated to theta points (m/s) !-- v3d 3d v-velocity interpolated to theta points (m/s) @@ -102,6 +95,23 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- ep1 constant for virtual temperature (r_v/r_d - 1) !-- ep2 constant for specific humidity calculation !-- karman von karman constant +!-- idiff diff3d BEP/BEM+BEM diffusion flag +!-- flag_bep flag to use BEP/BEP+BEM +!-- frc_urb2d urban fraction +!-- a_u_bep BEP/BEP+BEM implicit component u-mom +!-- a_v_bep BEP/BEP+BEM implicit component v-mom +!-- a_t_bep BEP/BEP+BEM implicit component pot. temp. +!-- a_q_bep BEP/BEP+BEM implicit component vapor mixing ratio +!-- a_e_bep BEP/BEP+BEM implicit component TKE +!-- b_u_bep BEP/BEP+BEM explicit component u-mom +!-- b_v_bep BEP/BEP+BEM explicit component v-mom +!-- b_t_bep BEP/BEP+BEM explicit component pot.temp. +!-- b_q_bep BEP/BEP+BEM explicit component vapor mixing ratio +!-- b_e_bep BEP/BEP+BEM explicit component TKE +!-- dlg_bep Height above ground Martilli et al. (2002) Eq. 24 +!-- dl_u_bep modified length scale Martilli et al. (2002) Eq. 22 +!-- sf_bep fraction of vertical surface not occupied by buildings +!-- vl_bep volume fraction of grid cell not occupied by buildings !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -122,8 +132,6 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- kte end index for k in tile !------------------------------------------------------------------------------- ! - integer,parameter :: ndiff = 3 - real,parameter :: rcl = 1.0 ! integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -131,1578 +139,340 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & integer, intent(in) :: ysu_topdown_pblmix ! - real, intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv + real(kind=kind_phys), intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv ! - real, intent(in ) :: ep1,ep2,karman + real(kind=kind_phys), intent(in ) :: ep1,ep2,karman ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: qv3d, & qc3d, & qi3d, & p3d, & pi3d, & - th3d, & t3d, & dz8w, & rthraten - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: p3di ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: rublten, & rvblten, & rthblten, & rqvblten, & - rqcblten + rqcblten, & + rqiblten ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: exch_h - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: wstar - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: delta - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & + intent(out ) :: exch_h, & + exch_m + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: wstar + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: delta + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(inout) :: u10, & v10 - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: uoce, & voce ! - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: xland, & hfx, & qfx, & br, & psfc - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & intent(in ) :: & psim, & psih - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: znt, & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(in ) :: znt, & ust, & - hpbl, & wspd + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & + intent(out ) :: hpbl ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: u3d, & v3d ! integer, dimension( ims:ime, jms:jme ) , & intent(out ) :: kpbl2d - logical, intent(in) :: flag_qi -! -!optional ! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(inout) :: regime -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - optional , & - intent(inout) :: rqiblten + logical, intent(in) :: flag_qc, & + flag_qi ! - real, dimension( kms:kme ) , & + integer, intent(in) :: idiff + logical, intent(in) :: flag_bep + real(kind=kind_phys), dimension( ims:ime, kms:kme, jms:jme ) , & optional , & - intent(in ) :: znu, & - znw -! - real, dimension( ims:ime, jms:jme ) , & + intent(in) :: a_u_bep, & + a_v_bep,a_t_bep, & + a_e_bep,b_u_bep, & + a_q_bep,b_q_bep, & + b_v_bep,b_t_bep, & + b_e_bep,dlg_bep, & + dl_u_bep, & + vl_bep,sf_bep + real(kind=kind_phys), dimension(ims:ime,jms:jme) , & optional , & - intent(in ) :: mut -! - real, optional, intent(in ) :: p_top + intent(in) :: frc_urb2d ! - real, dimension( ims:ime, jms:jme ) , & + real(kind=kind_phys), dimension( ims:ime, jms:jme ) , & optional , & intent(in ) :: ctopo, & ctopo2 +! + character(len=*), intent(out) :: errmsg + integer, intent(out) :: errflg !local integer :: i,j,k - real, dimension( its:ite, kts:kte*ndiff ) :: rqvbl2dt, & - qv2d - real, dimension( its:ite, kts:kte ) :: pdh - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite ) :: & - dusfc, & - dvsfc, & - dtsfc, & - dqsfc -#if defined(mpas) -!MPAS specific optional arguments for additional diagnostics: - real,intent(in),dimension(ims:ime,kms:kme,jms:jme),optional:: rho - real:: rho_d - real,intent(out),dimension(ims:ime,kms:kme,jms:jme),optional:: kzhout,kzmout,kzqout - do j = jts,jte - do k = kts,kte - do i = its,ite - kzhout(i,k,j) = 0. - kzmout(i,k,j) = 0. - kzqout(i,k,j) = 0. - enddo - enddo - enddo -!MPAS specific end. -#endif -! - qv2d(its:ite,:) = 0.0 -! - do j = jts,jte - if(present(mut))then -! -! For ARW we will replace p and p8w with dry hydrostatic pressure -! - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top - pdhi(i,k) = mut(i,j)*znw(k) + p_top - enddo - enddo - elseif(present(rho)) then - 203 format(1x,i4,1x,i2,10(1x,e15.8)) -!For MPAS, we replace the hydrostatic pressures defined at theta and w points by -!the dry hydrostatic pressures (Laura D. Fowler): - k = kte+1 - do i = its,ite - pdhi(i,k) = p3di(i,k,j) - enddo - do k = kte,kts,-1 - do i = its,ite - rho_d = rho(i,k,j) / (1. + qv3d(i,k,j)) - if(k.le.kte) pdhi(i,k) = pdhi(i,k+1) + g*rho_d*dz8w(i,k,j) - enddo - enddo - do k = kts,kte - do i = its,ite - pdh(i,k) = 0.5*(pdhi(i,k) + pdhi(i,k+1)) - enddo - enddo -!MPAS specific end. - else - do k = kts,kte+1 - do i = its,ite - if(k.le.kte)pdh(i,k) = p3d(i,k,j) - pdhi(i,k) = p3di(i,k,j) - enddo - enddo - endif - do k = kts,kte - do i = its,ite - qv2d(i,k) = qv3d(i,k,j) - qv2d(i,k+kte) = qc3d(i,k,j) - if(present(rqiblten)) qv2d(i,k+kte+kte) = qi3d(i,k,j) - enddo - enddo -! - call ysu2d(J=j,ux=u3d(ims,kms,j),vx=v3d(ims,kms,j) & - ,tx=t3d(ims,kms,j) & - ,qx=qv2d(its,kts) & - ,p2d=pdh(its,kts),p2di=pdhi(its,kts) & - ,pi2d=pi3d(ims,kms,j) & - ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j) & - ,ttnp=rthblten(ims,kms,j),qtnp=rqvbl2dt(its,kts),ndiff=ndiff & - ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & - ,xlv=xlv,rv=rv & - ,ep1=ep1,ep2=ep2,karman=karman & - ,dz8w2d=dz8w(ims,kms,j) & - ,psfcpa=psfc(ims,j),znt=znt(ims,j),ust=ust(ims,j) & - ,hpbl=hpbl(ims,j) & - ,regime=regime(ims,j),psim=psim(ims,j) & - ,psih=psih(ims,j),xland=xland(ims,j) & - ,hfx=hfx(ims,j),qfx=qfx(ims,j) & - ,wspd=wspd(ims,j),br=br(ims,j) & - ,dusfc=dusfc,dvsfc=dvsfc,dtsfc=dtsfc,dqsfc=dqsfc & - ,dt=dt,rcl=1.0,kpbl1d=kpbl2d(ims,j) & - ,exch_hx=exch_h(ims,kms,j) & - ,wstar=wstar(ims,j) & - ,delta=delta(ims,j) & - ,u10=u10(ims,j),v10=v10(ims,j) & - ,uox=uoce(ims,j),vox=voce(ims,j) & - ,rthraten=rthraten(ims,kms,j),p2diORG=p3di(ims,kms,j) & - ,ysu_topdown_pblmix=ysu_topdown_pblmix & - ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j) & -#if defined(mpas) -!MPAS specific optional arguments for additional diagnostics: - ,kzh=kzhout(ims,kms,j) & - ,kzm=kzmout(ims,kms,j) & - ,kzq=kzqout(ims,kms,j) & -#endif - ,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 ) -! - do k = kts,kte - do i = its,ite - rthblten(i,k,j) = rthblten(i,k,j)/pi3d(i,k,j) - rqvblten(i,k,j) = rqvbl2dt(i,k) - rqcblten(i,k,j) = rqvbl2dt(i,k+kte) - if(present(rqiblten)) rqiblten(i,k,j) = rqvbl2dt(i,k+kte+kte) - enddo - enddo -! - enddo -! - end subroutine ysu -! -!------------------------------------------------------------------------------- -! - subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & - utnp,vtnp,ttnp,qtnp,ndiff, & - cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & - dz8w2d,psfcpa, & - znt,ust,hpbl,psim,psih, & - xland,hfx,qfx,wspd,br, & - dusfc,dvsfc,dtsfc,dqsfc, & - dt,rcl,kpbl1d, & - exch_hx, & - wstar,delta, & - u10,v10, & - uox,vox, & - rthraten,p2diORG, & - ysu_topdown_pblmix, & - ctopo,ctopo2, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - !optional - regime & -#if defined(mpas) - !MPAS specific optional arguments for additional diagnostics: - ,kzh,kzm,kzq & -#endif - ) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! -! this code is a revised vertical diffusion package ("ysupbl") -! with a nonlocal turbulent mixing in the pbl after "mrfpbl". -! the ysupbl (hong et al. 2006) is based on the study of noh -! et al.(2003) and accumulated realism of the behavior of the -! troen and mahrt (1986) concept implemented by hong and pan(1996). -! the major ingredient of the ysupbl is the inclusion of an explicit -! treatment of the entrainment processes at the entrainment layer. -! this routine uses an implicit approach for vertical flux -! divergence and does not require "miter" timesteps. -! it includes vertical diffusion in the stable atmosphere -! and moist vertical diffusion in clouds. -! -! mrfpbl: -! coded by song-you hong (ncep), implemented by jimy dudhia (ncar) -! fall 1996 -! -! ysupbl: -! coded by song-you hong (yonsei university) and implemented by -! song-you hong (yonsei university) and jimy dudhia (ncar) -! summer 2002 -! -! further modifications : -! an enhanced stable layer mixing, april 2008 -! ==> increase pbl height when sfc is stable (hong 2010) -! pressure-level diffusion, april 2009 -! ==> negligible differences -! implicit forcing for momentum with clean up, july 2009 -! ==> prevents model blowup when sfc layer is too low -! incresea of lamda, maximum (30, 0.1 x del z) feb 2010 -! ==> prevents model blowup when delz is extremely large -! revised prandtl number at surface, peggy lemone, feb 2010 -! ==> increase kh, decrease mixing due to counter-gradient term -! revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011 -! ==> reduce the thermal strength when z1 < 0.1 h -! revised prandtl number for free convection, dudhia, mar 2012 -! ==> pr0 = 1 + bke (=0.272) when newtral, kh is reduced -! minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012 -! ==> weaker mixing when stable, and les resolution in vertical -! gz1oz0 is removed, and phim phih are ln(z1/z0)-phim,h, hong, mar 2012 -! ==> consider thermal z0 when differs from mechanical z0 -! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 -! ==> wscale becomes small with height, and less mixing in stable bl -! revision in background diffusion (kzo), jan 2016 -! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for -! internal wave mixing of large et al. (1994), songyou hong, feb 2016 -! ==> alleviate superious excessive mixing when delz is large -! -! references: -! -! hong (2010) quart. j. roy. met. soc -! hong, noh, and dudhia (2006), mon. wea. rev. -! hong and pan (1996), mon. wea. rev. -! noh, chun, hong, and raasch (2003), boundary layer met. -! troen and mahrt (1986), boundary layer met. -! -!------------------------------------------------------------------------------- -! - real,parameter :: xkzminm = 0.1,xkzminh = 0.01 - real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. - real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. - real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 - real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 - real,parameter :: phifac = 8.,sfcfrac = 0.1 - real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 - real,parameter :: h1 = 0.33333335, h2 = 0.6666667 - real,parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. - real,parameter :: tmin=1.e-2 - real,parameter :: gamcrt = 3.,gamcrq = 2.e-3 - real,parameter :: xka = 2.4e-5 - integer,parameter :: imvdif = 1 -! - integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - j,ndiff +!temporary allocation of local chemical species and/or passive tracers that are vertically- +!mixed in subroutine bl_ysu_run: + logical:: l_topdown_pblmix - integer, intent(in) :: ysu_topdown_pblmix -! - real, intent(in ) :: dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv -! - real, intent(in ) :: ep1,ep2,karman -! - real, dimension( ims:ime, kms:kme ), & - intent(in) :: dz8w2d, & - pi2d, & - p2diorg -! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: tx - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(in ) :: qx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: utnp, & - vtnp, & - ttnp - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(inout) :: qtnp -! - real, dimension( its:ite, kts:kte+1 ) , & - intent(in ) :: p2di -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: p2d -! - real, dimension( ims:ime ) , & - intent(inout) :: ust, & - hpbl, & - znt - real, dimension( ims:ime ) , & - intent(in ) :: xland, & - hfx, & - qfx -! - real, dimension( ims:ime ), intent(inout) :: wspd - real, dimension( ims:ime ), intent(in ) :: br -! - real, dimension( ims:ime ), intent(in ) :: psim, & - psih -! - real, dimension( ims:ime ), intent(in ) :: psfcpa - integer, dimension( ims:ime ), intent(out ) :: kpbl1d -! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: ux, & - vx, & - rthraten - real, dimension( ims:ime ) , & - optional , & - intent(in ) :: ctopo, & - ctopo2 - real, dimension( ims:ime ) , & - optional , & - intent(inout) :: regime -! -! local vars -! - real, dimension( its:ite ) :: hol - real, dimension( its:ite, kts:kte+1 ) :: zq -! - real, dimension( its:ite, kts:kte ) :: & - thx,thvx,thlix, & - del, & - dza, & - dzq, & - xkzom, & - xkzoh, & - za -! - real, dimension( its:ite ) :: & - rhox, & - govrth, & - zl1,thermal, & - wscale, & - hgamt,hgamq, & - brdn,brup, & - phim,phih, & - dusfc,dvsfc, & - dtsfc,dqsfc, & - prpbl, & - wspd1,thermalli -! - real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & - f1,f2, & - r1,r2, & - ad,au, & - cu, & - al, & - xkzq, & - zfac, & - rhox2, & - hgamt2 -! -!jdf added exch_hx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: exch_hx -! - real, dimension( ims:ime ) , & - intent(inout) :: u10, & - v10 - real, dimension( ims:ime ) , & - intent(in ) :: uox, & - vox - real, dimension( its:ite ) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro -! - real, dimension( its:ite, kts:kte, ndiff) :: r3,f3 - integer, dimension( its:ite ) :: kpbl,kpblold -! - logical, dimension( its:ite ) :: pblflg, & - sfcflg, & - stable, & - cloudflg + integer, parameter :: nmix = 0 + integer :: n - logical :: definebrup -! - integer :: n,i,k,l,ic,is,kk - integer :: klpbl, ktrace1, ktrace2, ktrace3 -! -! - real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 - real :: ss,ri,qmean,tmean,alph,chi,zk,rl2,dk,sri - real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz - real :: utend,vtend,ttend,qtend - real :: dtstep,govrthv - real :: cont, conq, conw, conwrc -! + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: qmix + real(kind=kind_phys), dimension(ims:ime,kms:kme,jms:jme,nmix):: rqmixblten - real, dimension( its:ite, kts:kte ) :: wscalek,wscalek2 - real, dimension( ims:ime ) :: wstar - real, dimension( ims:ime ) :: delta - real, dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & - zfacent,entfac - real, dimension( its:ite ) :: ust3, & - wstar3, & - wstar3_2, & - hgamu,hgamv, & - wm2, we, & - bfxpbl, & - hfxpbl,qfxpbl, & - ufxpbl,vfxpbl, & - dthvx - real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & - dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & - prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & - rcldb,bruptmp,radflux -! -#if defined(mpas) -!MPAS specific begin: - real,intent(out),dimension(ims:ime,kms:kme),optional::kzh,kzm,kzq -!MPAS specific end. -#endif + ! Local tile-sized arrays for contiguous data for bl_ysu_run call. -! -!------------------------------------------------------------------------------- -! - klpbl = kte -! - cont=cp/g - conq=xlv/g - conw=1./g - conwrc = conw*sqrt(rcl) - conpr = bfac*karman*sfcfrac -! -! k-start index for tracer diffusion -! - ktrace1 = 0 - ktrace2 = 0 + kte - ktrace3 = 0 + kte*2 -! - do k = kts,kte - do i = its,ite - thx(i,k) = tx(i,k)/pi2d(i,k) - thlix(i,k) = (tx(i,k)-xlv*qx(i,ktrace2+k)/cp-2.834E6*qx(i,ktrace3+k)/cp)/pi2d(i,k) - enddo - enddo -! - do k = kts,kte - do i = its,ite - tvcon = (1.+ep1*qx(i,k)) - thvx(i,k) = thx(i,k)*tvcon - enddo - enddo -! - do i = its,ite - tvcon = (1.+ep1*qx(i,1)) - rhox(i) = psfcpa(i)/(rd*tx(i,1)*tvcon) - govrth(i) = g/thx(i,1) - enddo -! -!-----compute the height of full- and half-sigma levels above ground -! level, and the layer thicknesses. -! - do i = its,ite - zq(i,1) = 0. - enddo -! - do k = kts,kte - do i = its,ite - zq(i,k+1) = dz8w2d(i,k)+zq(i,k) - tvcon = (1.+ep1*qx(i,k)) - rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) - enddo - enddo -! - do k = kts,kte - do i = its,ite - za(i,k) = 0.5*(zq(i,k)+zq(i,k+1)) - dzq(i,k) = zq(i,k+1)-zq(i,k) - del(i,k) = p2di(i,k)-p2di(i,k+1) - enddo - enddo -! - do i = its,ite - dza(i,1) = za(i,1) - enddo -! - do k = kts+1,kte - do i = its,ite - dza(i,k) = za(i,k)-za(i,k-1) - enddo - enddo -! -! -!-----initialize vertical tendencies and -! - utnp(its:ite,:) = 0. - vtnp(its:ite,:) = 0. - ttnp(its:ite,:) = 0. - qtnp(its:ite,:) = 0. -! - do i = its,ite - wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9 - enddo -! -!---- compute vertical diffusion -! -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! compute preliminary variables -! - dtstep = dt - dt2 = 2.*dtstep - rdt = 1./dt2 -! - do i = its,ite - bfxpbl(i) = 0.0 - hfxpbl(i) = 0.0 - qfxpbl(i) = 0.0 - ufxpbl(i) = 0.0 - vfxpbl(i) = 0.0 - hgamu(i) = 0.0 - hgamv(i) = 0.0 - delta(i) = 0.0 - wstar3_2(i) = 0.0 - enddo -! -!MPAS specific begin: Added initialization of local vertical diffusion coefficients: - if(present(kzh) .and. present(kzm) .and. present(kzq)) then - do k = kts,kte - do i = its,ite - xkzh(i,k) = 0.0 - xkzm(i,k) = 0.0 - xkzhl(i,k) = 0.0 - xkzml(i,k) = 0.0 - enddo - enddo - endif -!MPAS specific end. -! - do k = kts,klpbl - do i = its,ite - wscalek(i,k) = 0.0 - wscalek2(i,k) = 0.0 - enddo - enddo -! - do k = kts,klpbl - do i = its,ite - zfac(i,k) = 0.0 - enddo - enddo - do k = kts,klpbl-1 - do i = its,ite - xkzom(i,k) = xkzminm - xkzoh(i,k) = xkzminh - enddo - enddo -! - do i = its,ite - dusfc(i) = 0. - dvsfc(i) = 0. - dtsfc(i) = 0. - dqsfc(i) = 0. - enddo -! - do i = its,ite - hgamt(i) = 0. - hgamq(i) = 0. - wscale(i) = 0. - kpbl(i) = 1 - hpbl(i) = zq(i,1) - zl1(i) = za(i,1) - thermal(i)= thvx(i,1) - thermalli(i) = thlix(i,1) - pblflg(i) = .true. - sfcflg(i) = .true. - sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) - if(br(i).gt.0.0) sfcflg(i) = .false. - enddo -! -! compute the first guess of pbl height -! - do i = its,ite - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! - do i = its,ite - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - enddo -! - do i = its,ite - fm = psim(i) - fh = psih(i) - zol1(i) = max(br(i)*fm*fm/fh,rimin) - if(sfcflg(i))then - zol1(i) = min(zol1(i),-zfmin) - else - zol1(i) = max(zol1(i),zfmin) - endif - hol1 = zol1(i)*hpbl(i)/zl1(i)*sfcfrac - if(sfcflg(i))then - phim(i) = (1.-aphi16*hol1)**(-1./4.) - phih(i) = (1.-aphi16*hol1)**(-1./2.) - bfx0 = max(sflux(i),0.) - hfx0 = max(hfx(i)/rhox(i)/cp,0.) - qfx0 = max(ep1*thx(i,1)*qfx(i)/rhox(i),0.) - wstar3(i) = (govrth(i)*bfx0*hpbl(i)) - wstar(i) = (wstar3(i))**h1 - else - phim(i) = (1.+aphi5*hol1) - phih(i) = phim(i) - wstar(i) = 0. - wstar3(i) = 0. - endif - ust3(i) = ust(i)**3. - wscale(i) = (ust3(i)+phifac*karman*wstar3(i)*0.5)**h1 - wscale(i) = min(wscale(i),ust(i)*aphi16) - wscale(i) = max(wscale(i),ust(i)/aphi5) - enddo -! -! compute the surface variables for pbl height estimation -! under unstable conditions -! - do i = its,ite - if(sfcflg(i).and.sflux(i).gt.0.0)then - gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) - hgamq(i) = min(gamfac*qfx(i),gamcrq) - vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac - thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) - thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) - hgamt(i) = max(hgamt(i),0.0) - hgamq(i) = max(hgamq(i),0.0) - brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) - hgamu(i) = brint*ux(i,1) - hgamv(i) = brint*vx(i,1) - else - pblflg(i) = .false. - endif - enddo -! -! enhance the pbl height by considering the thermal -! - do i = its,ite - if(pblflg(i))then - kpbl(i) = 1 - hpbl(i) = zq(i,1) - endif - enddo -! - do i = its,ite - if(pblflg(i))then - stable(i) = .false. - brup(i) = br(i) - brcr(i) = brcr_ub - endif - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i).and.pblflg(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! -! enhance pbl by theta-li -! - if (ysu_topdown_pblmix.eq.1)then - do i = its,ite - kpblold(i) = kpbl(i) - definebrup=.false. - do k = kpblold(i), kte-1 - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 - stable(i) = bruptmp.ge.brcr(i) - if (definebrup) then - kpbl(i) = k - brup(i) = bruptmp - definebrup=.false. - endif - if (.not.stable(i)) then !overwrite brup brdn values - brdn(i)=bruptmp - definebrup=.true. - pblflg(i)=.true. - endif - enddo - enddo - endif + real(kind=kind_phys), dimension(its:ite,kts:kte,nmix) :: & + qmix_hv , & + rqmixblten_hv - do i = its,ite - if(pblflg(i)) then - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -! -! stable boundary layer -! - do i = its,ite - if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then - brup(i) = br(i) - stable(i) = .false. - else - stable(i) = .true. - endif - enddo -! - do i = its,ite - if((.not.stable(i)).and.((xland(i)-1.5).ge.0))then - wspd10 = u10(i)*u10(i) + v10(i)*v10(i) - wspd10 = sqrt(wspd10) - ross = wspd10 / (cori*znt(i)) - brcr_sbro(i) = min(0.16*(1.e-7*ross)**(-0.18),.3) - endif - enddo -! - do i = its,ite - if(.not.stable(i))then - if((xland(i)-1.5).ge.0)then - brcr(i) = brcr_sbro(i) - else - brcr(i) = brcr_sb - endif - endif - enddo -! - do k = 2,klpbl - do i = its,ite - if(.not.stable(i))then - brdn(i) = brup(i) - spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) - brup(i) = (thvx(i,k)-thermal(i))*(g*za(i,k)/thvx(i,1))/spdk2 - kpbl(i) = k - stable(i) = brup(i).gt.brcr(i) - endif - enddo - enddo -! - do i = its,ite - if((.not.sfcflg(i)).and.hpbl(i).lt.zq(i,2)) then - k = kpbl(i) - if(brdn(i).ge.brcr(i))then - brint = 0. - elseif(brup(i).le.brcr(i))then - brint = 1. - else - brint = (brcr(i)-brdn(i))/(brup(i)-brdn(i)) - endif - hpbl(i) = za(i,k-1)+brint*(za(i,k)-za(i,k-1)) - if(hpbl(i).lt.zq(i,2)) kpbl(i) = 1 - if(kpbl(i).le.1) pblflg(i) = .false. - endif - enddo -! -! estimate the entrainment parameters -! - do i = its,ite - cloudflg(i)=.false. - if(pblflg(i)) then - k = kpbl(i) - 1 - wm3 = wstar3(i) + 5. * ust3(i) - wm2(i) = wm3**h2 - bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) - if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then - if ( kpbl(i) .ge. 2) then - cloudflg(i)=.true. - templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp - !rvls is ws at full level - rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) - temps=templ + ((qx(i,k)+qx(i,ktrace2+k))-rvls)/(cp/xlv + & - ep2*xlv*rvls/(rd*templ**2)) - rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) - rcldb=max((qx(i,k)+qx(i,ktrace2+k))-rvls,0.) - !entrainment efficiency - dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2)+qx(i,ktrace2+k+2))) & - - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k) +qx(i,ktrace2+k))) - dthvx(i) = max(dthvx(i),0.1) - tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) - ent_eff = 0.2 * 8. * tmp1 +0.2 + real(kind=kind_phys), dimension(its:ite,kts:kte) :: & + u3d_hv , & + v3d_hv , & + t3d_hv , & + qv3d_hv , & + qc3d_hv , & + qi3d_hv , & + p3d_hv , & + pi3d_hv , & + rublten_hv , & + rvblten_hv , & + rthblten_hv , & + rqvblten_hv , & + rqcblten_hv , & + rqiblten_hv , & + dz8w_hv , & + exch_h_hv , & + exch_m_hv , & + rthraten_hv - radsum=0. - do kk = 1,kpbl(i)-1 - radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s - radflux=radflux*cp/g*(p2diORG(i,kk)-p2diORG(i,kk+1)) ! converts temp/s to W/m^2 - if (radflux < 0.0 ) radsum=abs(radflux)+radsum - enddo - radsum=max(radsum,0.0) + real(kind=kind_phys), dimension(its:ite,kts:kte) :: & + a_u_hv , & + a_v_hv , & + a_t_hv , & + a_e_hv , & + b_u_hv , & + a_q_hv , & + b_q_hv , & + b_v_hv , & + b_t_hv , & + b_e_hv , & + dlg_hv , & + dl_u_hv , & + vlk_hv , & + sfk_hv + real(kind=kind_phys), dimension(its:ite,kts:kte+1) :: & + p3di_hv - !recompute entrainment from sfc thermals - bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) - bfx0 = max(sflux(i),0.0) - wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) - wm2(i) = wm3**h2 - bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + real(kind=kind_phys), dimension(its:ite) :: & + psfc_hv , & + znt_hv , & + ust_hv , & + hpbl_hv , & + psim_hv , & + psih_hv , & + xland_hv , & + hfx_hv , & + qfx_hv , & + wspd_hv , & + br_hv , & + wstar_hv , & + delta_hv , & + u10_hv , & + v10_hv , & + uoce_hv , & + voce_hv , & + ctopo_hv , & + ctopo2_hv - !entrainment from PBL top thermals - bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) - bfx0 = max(radsum/rhox2(i,k)/cp,0.) - wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) - wm2(i) = wm2(i)+wm3**h2 - bfxpbl(i) = - ent_eff * bfx0 - dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) - we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + integer, dimension(its:ite) :: & + kpbl2d_hv + real(kind=kind_phys), dimension(its:ite) :: & + frcurb_hv - !wstar3_2 - bfx0 = max(radsum/rhox2(i,k)/cp,0.) - wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) - !recompute hgamt - wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 - wscale(i) = min(wscale(i),ust(i)*aphi16) - wscale(i) = max(wscale(i),ust(i)/aphi5) - gamfac = bfac/rhox(i)/wscale(i) - hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) - hgamq(i) = min(gamfac*qfx(i),gamcrq) - gamfac = bfac/rhox2(i,k)/wscale(i) - hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) - hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) - brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) - hgamu(i) = brint*ux(i,1) - hgamv(i) = brint*vx(i,1) - endif - endif - prpbl(i) = 1.0 - dthx = max(thx(i,k+1)-thx(i,k),tmin) - dqx = min(qx(i,k+1)-qx(i,k),0.0) - hfxpbl(i) = we(i)*dthx - qfxpbl(i) = we(i)*dqx -! - dux = ux(i,k+1)-ux(i,k) - dvx = vx(i,k+1)-vx(i,k) - if(dux.gt.tmin) then - ufxpbl(i) = max(prpbl(i)*we(i)*dux,-ust(i)*ust(i)) - elseif(dux.lt.-tmin) then - ufxpbl(i) = min(prpbl(i)*we(i)*dux,ust(i)*ust(i)) - else - ufxpbl(i) = 0.0 - endif - if(dvx.gt.tmin) then - vfxpbl(i) = max(prpbl(i)*we(i)*dvx,-ust(i)*ust(i)) - elseif(dvx.lt.-tmin) then - vfxpbl(i) = min(prpbl(i)*we(i)*dvx,ust(i)*ust(i)) - else - vfxpbl(i) = 0.0 - endif - delb = govrth(i)*d3*hpbl(i) - delta(i) = min(d1*hpbl(i) + d2*wm2(i)/delb,100.) - endif - enddo -! - do k = kts,klpbl - do i = its,ite - if(pblflg(i).and.k.ge.kpbl(i))then - entfac(i,k) = ((zq(i,k+1)-hpbl(i))/delta(i))**2. - else - entfac(i,k) = 1.e30 - endif - enddo - enddo -! -! compute diffusion coefficients below pbl -! - do k = kts,klpbl - do i = its,ite - if(k.lt.kpbl(i)) then - zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) - zfacent(i,k) = (1.-zfac(i,k))**3. - wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 - wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 - if(sfcflg(i)) then - prfac = conpr - prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) - prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. - else - prfac = 0. - prfac2 = 0. - prnumfac = 0. - phim8z = 1.+aphi5*zol1(i)*zq(i,k+1)/zl1(i) - wscalek(i,k) = ust(i)/phim8z - wscalek(i,k) = max(wscalek(i,k),0.001) - endif - prnum0 = (phih(i)/phim(i)+prfac) - prnum0 = max(min(prnum0,prmax),prmin) - xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & - wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac - !Do not include xkzm at kpbl-1 since it changes entrainment - if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then - xkzm(i,k) = 0.0 - endif - prnum = 1. + (prnum0-1.)*exp(prnumfac) - xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) - prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) - prnum = 1. + (prnum0-1.)*exp(prnumfac) - xkzh(i,k) = xkzm(i,k)/prnum - xkzm(i,k) = xkzm(i,k)+xkzom(i,k) - xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) - xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzq(i,k) = min(xkzq(i,k),xkzmax) - endif - enddo - enddo -! -! compute diffusion coefficients over pbl (free atmosphere) -! - do k = kts,kte-1 - do i = its,ite - if(k.ge.kpbl(i)) then - ss = ((ux(i,k+1)-ux(i,k))*(ux(i,k+1)-ux(i,k)) & - +(vx(i,k+1)-vx(i,k))*(vx(i,k+1)-vx(i,k))) & - /(dza(i,k+1)*dza(i,k+1))+1.e-9 - govrthv = g/(0.5*(thvx(i,k+1)+thvx(i,k))) - ri = govrthv*(thvx(i,k+1)-thvx(i,k))/(ss*dza(i,k+1)) - if(imvdif.eq.1.and.ndiff.ge.3)then - if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.(qx(i & - ,ktrace2+k+1)+qx(i,ktrace3+k+1)).gt.0.01e-3)then -! in cloud - qmean = 0.5*(qx(i,k)+qx(i,k+1)) - tmean = 0.5*(tx(i,k)+tx(i,k+1)) - alph = xlv*qmean/rd/tmean - chi = xlv*xlv*qmean/cp/rv/tmean/tmean - ri = (1.+alph)*(ri-g*g/ss/tmean/cp*((chi-alph)/(1.+chi))) - endif - endif - zk = karman*zq(i,k+1) - rlamdz = min(max(0.1*dza(i,k+1),rlam),300.) - rlamdz = min(dza(i,k+1),rlamdz) - rl2 = (zk*rlamdz/(rlamdz+zk))**2 - dk = rl2*sqrt(ss) - if(ri.lt.0.)then -! unstable regime - ri = max(ri, rimin) - sri = sqrt(-ri) - xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri)) - xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri)) - else -! stable regime - xkzh(i,k) = dk/(1+5.*ri)**2 - prnum = 1.0+2.1*ri - prnum = min(prnum,prmax) - xkzm(i,k) = xkzh(i,k)*prnum - endif -! - xkzm(i,k) = xkzm(i,k)+xkzom(i,k) - xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzml(i,k) = xkzm(i,k) - xkzhl(i,k) = xkzh(i,k) - endif - enddo - enddo -! -! compute tridiagonal matrix elements for heat -! - do k = kts,kte - do i = its,ite - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - enddo - enddo -! - do i = its,ite - ad(i,1) = 1. - f1(i,1) = thx(i,1)-300.+hfx(i)/cont/del(i,1)*dt2 - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzh(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzt = tem1*(-hgamt(i)/hpbl(i)-hfxpbl(i)*zfacent(i,k)/xkzh(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzt - f1(i,k+1) = thx(i,k+1)-300.-dtodsu*dsdzt - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) - xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) - xkzh(i,k) = min(xkzh(i,k),xkzmax) - f1(i,k+1) = thx(i,k+1)-300. - else - f1(i,k+1) = thx(i,k+1)-300. - endif - tem1 = dsig*xkzh(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - enddo - enddo -! - call tridin_ysu(al,ad,cu,r1,au,f1,its,ite,kts,kte,1) -! -! recover tendencies of heat -! - do k = kte,kts,-1 - do i = its,ite - ttend = (f1(i,k)-thx(i,k)+300.)*rdt*pi2d(i,k) - ttnp(i,k) = ttnp(i,k)+ttend - dtsfc(i) = dtsfc(i)+ttend*cont*del(i,k)/pi2d(i,k) - enddo - enddo -! -! compute tridiagonal matrix elements for moisture, clouds, and gases -! - do k = kts,kte - do i = its,ite - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - enddo - enddo -! - do ic = 1,ndiff - do i = its,ite - do k = kts,kte - f3(i,k,ic) = 0. - enddo - enddo - enddo -! - do i = its,ite - ad(i,1) = 1. - f3(i,1,1) = qx(i,1)+qfx(i)*g/del(i,1)*dt2 - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do i = its,ite - f3(i,1,ic) = qx(i,1+is) - enddo - enddo - endif -! - do k = kts,kte-1 - do i = its,ite - if(k.ge.kpbl(i)) then - xkzq(i,k) = xkzh(i,k) - endif - enddo - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzq(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i)) then - dsdzq = tem1*(-qfxpbl(i)*zfacent(i,k)/xkzq(i,k)) - f3(i,k,1) = f3(i,k,1)+dtodsd*dsdzq - f3(i,k+1,1) = qx(i,k+1)-dtodsu*dsdzq - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) - xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) - xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) - xkzq(i,k) = min(xkzq(i,k),xkzmax) - f3(i,k+1,1) = qx(i,k+1) - else - f3(i,k+1,1) = qx(i,k+1) - endif - tem1 = dsig*xkzq(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) -! exch_hx(i,k+1) = xkzh(i,k) - enddo - enddo +!----------------------------------------------------------------------------------------------------------------- + + l_topdown_pblmix = .false. + if(ysu_topdown_pblmix .eq. 1) l_topdown_pblmix = .true. + + do j = jts,jte ! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do k = kts,kte-1 - do i = its,ite - f3(i,k+1,ic) = qx(i,k+1+is) + ! Assign input data to local tile-sized arrays. + + do n = 1, nmix + do k = kts, kte + do i = its, ite + qmix_hv(i,k,n) = qmix(i,k,j,n) + end do + end do + end do + + do k = kts, kte+1 + do i = its, ite + p3di_hv(i,k) = p3di(i,k,j) + end do + end do + + do k = kts, kte + do i = its, ite + u3d_hv(i,k) = u3d(i,k,j) + v3d_hv(i,k) = v3d(i,k,j) + t3d_hv(i,k) = t3d(i,k,j) + qv3d_hv(i,k) = qv3d(i,k,j) + qc3d_hv(i,k) = qc3d(i,k,j) + qi3d_hv(i,k) = qi3d(i,k,j) + p3d_hv(i,k) = p3d(i,k,j) + pi3d_hv(i,k) = pi3d(i,k,j) + dz8w_hv(i,k) = dz8w(i,k,j) + rthraten_hv(i,k) = rthraten(i,k,j) + end do + end do + + if(present(a_u_bep) .and. present(a_v_bep) .and. present(a_t_bep) .and. & + present(a_q_bep) .and. present(a_e_bep) .and. present(b_u_bep) .and. & + present(b_v_bep) .and. present(b_t_bep) .and. present(b_q_bep) .and. & + present(b_e_bep) .and. present(dlg_bep) .and. present(dl_u_bep) .and. & + present(sf_bep) .and. present(vl_bep) .and. present(frc_urb2d)) then + do k = kts, kte + do i = its,ite + a_u_hv(i,k) = a_u_bep(i,k,j) + a_v_hv(i,k) = a_v_bep(i,k,j) + a_t_hv(i,k) = a_t_bep(i,k,j) + a_q_hv(i,k) = a_q_bep(i,k,j) + a_e_hv(i,k) = a_e_bep(i,k,j) + b_u_hv(i,k) = b_u_bep(i,k,j) + b_v_hv(i,k) = b_v_bep(i,k,j) + b_t_hv(i,k) = b_t_bep(i,k,j) + b_q_hv(i,k) = b_q_bep(i,k,j) + b_e_hv(i,k) = b_e_bep(i,k,j) + dlg_hv(i,k) = dlg_bep(i,k,j) + dl_u_hv(i,k) = dl_u_bep(i,k,j) + vlk_hv(i,k) = vl_bep(i,k,j) + sfk_hv(i,k) = sf_bep(i,k,j) + enddo enddo - enddo - enddo - endif -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - enddo - enddo -! - do ic = 1,ndiff - do k = kts,kte - do i = its,ite - r3(i,k,ic) = f3(i,k,ic) - enddo - enddo - enddo -! -! solve tridiagonal problem for moisture, clouds, and gases -! - call tridin_ysu(al,ad,cu,r3,au,f3,its,ite,kts,kte,ndiff) -! -! recover tendencies of heat and moisture -! - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,1)-qx(i,k))*rdt - qtnp(i,k) = qtnp(i,k)+qtend - dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) - enddo - enddo -! - if(ndiff.ge.2) then - do ic = 2,ndiff - is = (ic-1) * kte - do k = kte,kts,-1 - do i = its,ite - qtend = (f3(i,k,ic)-qx(i,k+is))*rdt - qtnp(i,k+is) = qtnp(i,k+is)+qtend + do i = its, ite + frcurb_hv(i) = frc_urb2d(i,j) enddo - enddo - enddo - endif -! -! compute tridiagonal matrix elements for momentum -! - do i = its,ite - do k = kts,kte - au(i,k) = 0. - al(i,k) = 0. - ad(i,k) = 0. - f1(i,k) = 0. - f2(i,k) = 0. - enddo - enddo -! - do i = its,ite -! paj: ctopo=1 if topo_wind=0 (default) -! mchen add this line to make sure NMM can still work with YSU PBL - if(present(ctopo)) then - ad(i,1) = 1.+ctopo(i)*ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - else - ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2 & - *(wspd1(i)/wspd(i))**2 - endif - f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) - f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i) - enddo -! - do k = kts,kte-1 - do i = its,ite - dtodsd = dt2/del(i,k) - dtodsu = dt2/del(i,k+1) - dsig = p2d(i,k)-p2d(i,k+1) - rdz = 1./dza(i,k+1) - tem1 = dsig*xkzm(i,k)*rdz - if(pblflg(i).and.k.lt.kpbl(i))then - dsdzu = tem1*(-hgamu(i)/hpbl(i)-ufxpbl(i)*zfacent(i,k)/xkzm(i,k)) - dsdzv = tem1*(-hgamv(i)/hpbl(i)-vfxpbl(i)*zfacent(i,k)/xkzm(i,k)) - f1(i,k) = f1(i,k)+dtodsd*dsdzu - f1(i,k+1) = ux(i,k+1)-dtodsu*dsdzu - f2(i,k) = f2(i,k)+dtodsd*dsdzv - f2(i,k+1) = vx(i,k+1)-dtodsu*dsdzv - elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then - xkzm(i,k) = prpbl(i)*xkzh(i,k) - xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) - xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) - xkzm(i,k) = min(xkzm(i,k),xkzmax) - f1(i,k+1) = ux(i,k+1) - f2(i,k+1) = vx(i,k+1) - else - f1(i,k+1) = ux(i,k+1) - f2(i,k+1) = vx(i,k+1) - endif - tem1 = dsig*xkzm(i,k)*rdz - dsdz2 = tem1*rdz - au(i,k) = -dtodsd*dsdz2 - al(i,k) = -dtodsu*dsdz2 - ad(i,k) = ad(i,k)-au(i,k) - ad(i,k+1) = 1.-al(i,k) - enddo - enddo -! -! copies here to avoid duplicate input args for tridin -! - do k = kts,kte - do i = its,ite - cu(i,k) = au(i,k) - r1(i,k) = f1(i,k) - r2(i,k) = f2(i,k) - enddo - enddo -! -! solve tridiagonal problem for momentum -! - call tridi1n(al,ad,cu,r1,r2,au,f1,f2,its,ite,kts,kte,1) -! -! recover tendencies of momentum -! - do k = kte,kts,-1 - do i = its,ite - utend = (f1(i,k)-ux(i,k))*rdt - vtend = (f2(i,k)-vx(i,k))*rdt - utnp(i,k) = utnp(i,k)+utend - vtnp(i,k) = vtnp(i,k)+vtend - dusfc(i) = dusfc(i) + utend*conwrc*del(i,k) - dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) - enddo - enddo -! -! paj: ctopo2=1 if topo_wind=0 (default) -! - do i = its,ite - if(present(ctopo).and.present(ctopo2)) then ! mchen for NMM - u10(i) = ctopo2(i)*u10(i)+(1-ctopo2(i))*ux(i,1) - v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) - endif !mchen - enddo -! -!---- end of vertical diffusion -! - do i = its,ite - kpbl1d(i) = kpbl(i) - enddo -! -!MPAS specific begin: - if(present(kzh) .and. present(kzm) .and. present(kzq)) then - do i = its,ite - do k = kts,kte - kzh(i,k) = xkzh(i,k) - kzm(i,k) = xkzm(i,k) - kzq(i,k) = xkzq(i,k) - enddo - enddo - endif -!MPAS specific end. -! - end subroutine ysu2d -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridi1n(cl,cm,cu,r1,r2,au,f1,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: its,ite, kts,kte, nt -! - real, dimension( its:ite, kts+1:kte+1 ) , & - intent(in ) :: cl -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: cm, & - r1 - real, dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 -! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: au, & - cu, & - f1 - real, dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do i = its,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - f1(i,1) = fk*r1(i,1) - enddo -! - do it = 1,nt - do i = its,l - fk = 1./cm(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo -! - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - f1(i,k) = fk*(r1(i,k)-cl(i,k)*f1(i,k-1)) - enddo - enddo -! - do it = 1,nt - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) - enddo - enddo - enddo -! - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f1(i,n) = fk*(r1(i,n)-cl(i,n)*f1(i,n-1)) - enddo -! - do it = 1,nt - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) - enddo - enddo -! - do k = n-1,kts,-1 - do i = its,l - f1(i,k) = f1(i,k)-au(i,k)*f1(i,k+1) - enddo - enddo -! - do it = 1,nt - do k = n-1,kts,-1 - do i = its,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo - enddo -! - end subroutine tridi1n -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - integer, intent(in ) :: its,ite, kts,kte, nt -! - real, dimension( its:ite, kts+1:kte+1 ) , & - intent(in ) :: cl -! - real, dimension( its:ite, kts:kte ) , & - intent(in ) :: cm - real, dimension( its:ite, kts:kte,nt ) , & - intent(in ) :: r2 -! - real, dimension( its:ite, kts:kte ) , & - intent(inout) :: au, & - cu - real, dimension( its:ite, kts:kte,nt ) , & - intent(inout) :: f2 -! - real :: fk - integer :: i,k,l,n,it -! -!------------------------------------------------------------------------------- -! - l = ite - n = kte -! - do it = 1,nt - do i = its,l - fk = 1./cm(i,1) - au(i,1) = fk*cu(i,1) - f2(i,1,it) = fk*r2(i,1,it) - enddo - enddo -! - do it = 1,nt - do k = kts+1,n-1 - do i = its,l - fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1)) - au(i,k) = fk*cu(i,k) - f2(i,k,it) = fk*(r2(i,k,it)-cl(i,k)*f2(i,k-1,it)) - enddo - enddo - enddo -! - do it = 1,nt - do i = its,l - fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1)) - f2(i,n,it) = fk*(r2(i,n,it)-cl(i,n)*f2(i,n-1,it)) - enddo - enddo -! - do it = 1,nt - do k = n-1,kts,-1 - do i = its,l - f2(i,k,it) = f2(i,k,it)-au(i,k)*f2(i,k+1,it) - enddo - enddo + endif + + do i = its, ite + psfc_hv(i) = psfc(i,j) + znt_hv(i) = znt(i,j) + ust_hv(i) = ust(i,j) + wspd_hv(i) = wspd(i,j) + psim_hv(i) = psim(i,j) + psih_hv(i) = psih(i,j) + xland_hv(i) = xland(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + br_hv(i) = br(i,j) + u10_hv(i) = u10(i,j) + v10_hv(i) = v10(i,j) + uoce_hv(i) = uoce(i,j) + voce_hv(i) = voce(i,j) + ctopo_hv(i) = ctopo(i,j) + ctopo2_hv(i) = ctopo2(i,j) + end do +! + call bl_ysu_run(ux=u3d_hv,vx=v3d_hv & + ,tx=t3d_hv & + ,qvx=qv3d_hv,qcx=qc3d_hv,qix=qi3d_hv & + ,f_qc=flag_qc,f_qi=flag_qi & + ,nmix=nmix,qmix=qmix_hv & + ,p2d=p3d_hv,p2di=p3di_hv & + ,pi2d=pi3d_hv & + ,utnp=rublten_hv,vtnp=rvblten_hv & + ,ttnp=rthblten_hv,qvtnp=rqvblten_hv & + ,qctnp=rqcblten_hv,qitnp=rqiblten_hv & + ,qmixtnp=rqmixblten_hv & + ,cp=cp,g=g,rovcp=rovcp,rd=rd,rovg=rovg & + ,xlv=xlv,rv=rv & + ,ep1=ep1,ep2=ep2,karman=karman & + ,dz8w2d=dz8w_hv & + ,psfcpa=psfc_hv,znt=znt_hv,ust=ust_hv & + ,hpbl=hpbl_hv & + ,psim=psim_hv & + ,psih=psih_hv,xland=xland_hv & + ,hfx=hfx_hv,qfx=qfx_hv & + ,wspd=wspd_hv,br=br_hv & + ,dt=dt,kpbl1d=kpbl2d_hv & + ,exch_hx=exch_h_hv & + ,exch_mx=exch_m_hv & + ,wstar=wstar_hv & + ,delta=delta_hv & + ,u10=u10_hv,v10=v10_hv & + ,uox=uoce_hv,vox=voce_hv & + ,rthraten=rthraten_hv & + ,ysu_topdown_pblmix=l_topdown_pblmix & + ,ctopo=ctopo_hv,ctopo2=ctopo2_hv & + ,a_u=a_u_hv,a_v=a_v_hv,a_t=a_t_hv,a_q=a_q_hv,a_e=a_e_hv & + ,b_u=b_u_hv,b_v=b_v_hv,b_t=b_t_hv,b_q=b_q_hv,b_e=b_e_hv & + ,sfk=sfk_hv,vlk=vlk_hv,dlu=dl_u_hv,dlg=dlg_hv,frcurb=frcurb_hv & + ,flag_bep=flag_bep & + ,its=its,ite=ite,kte=kte,kme=kme & + ,errmsg=errmsg,errflg=errflg ) +! + ! Assign local data back to full-sized arrays. + ! Only required for the INTENT(OUT) or INTENT(INOUT) arrays. + + do n = 1, nmix + do k = kts, kte + do i = its, ite + rqmixblten(i,k,j,n) = rqmixblten_hv(i,k,n) + end do + end do + end do + + do k = kts, kte + do i = its, ite + rublten(i,k,j) = rublten_hv(i,k) + rvblten(i,k,j) = rvblten_hv(i,k) +#if (NEED_B4B_DURING_CCPP_TESTING == 1) + rthblten(i,k,j) = rthblten_hv(i,k)/pi3d_hv(i,k) +#elif (NEED_B4B_DURING_CCPP_TESTING != 1) + rthblten(i,k,j) = rthblten_hv(i,k) +#endif + rqvblten(i,k,j) = rqvblten_hv(i,k) + rqcblten(i,k,j) = rqcblten_hv(i,k) + rqiblten(i,k,j) = rqiblten_hv(i,k) + exch_h(i,k,j) = exch_h_hv(i,k) + exch_m(i,k,j) = exch_m_hv(i,k) + end do + end do + + do i = its, ite + u10(i,j) = u10_hv(i) + v10(i,j) = v10_hv(i) + hpbl(i,j) = hpbl_hv(i) + kpbl2d(i,j) = kpbl2d_hv(i) + wstar(i,j) = wstar_hv(i) + delta(i,j) = delta_hv(i) + end do enddo -! - end subroutine tridin_ysu -!------------------------------------------------------------------------------- -! -!------------------------------------------------------------------------------- - subroutine ysuinit(rublten,rvblten,rthblten,rqvblten, & - rqcblten,rqiblten,p_qi,p_first_scalar, & - restart, allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -!------------------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------- -! - logical , intent(in) :: restart, allowed_to_read - integer , intent(in) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - integer , intent(in) :: p_qi,p_first_scalar - real , dimension( ims:ime , kms:kme , jms:jme ), intent(out) :: & - rublten, & - rvblten, & - rthblten, & - rqvblten, & - rqcblten, & - rqiblten - 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 - rublten(i,k,j) = 0. - rvblten(i,k,j) = 0. - rthblten(i,k,j) = 0. - rqvblten(i,k,j) = 0. - rqcblten(i,k,j) = 0. - enddo - enddo - enddo - endif -! - if (p_qi .ge. p_first_scalar .and. .not.restart) then - do j = jts,jtf - do k = kts,ktf - do i = its,itf - rqiblten(i,k,j) = 0. - enddo - enddo - enddo - endif -! - end subroutine ysuinit -!------------------------------------------------------------------------------- -end module module_bl_ysu -!------------------------------------------------------------------------------- + + end subroutine ysu + +!================================================================================================================= + end module module_bl_ysu +!================================================================================================================= 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 02fa16cc8b..806de7c518 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F +++ b/src/core_atmosphere/physics/physics_wrf/module_cu_ntiedtke.F @@ -1,158 +1,37 @@ !================================================================================================================= -! copied for implementation in MPAS from WRF version 3.8.1: + module module_cu_ntiedtke + use mpas_kind_types,only: kind_phys => RKIND + use cu_ntiedtke,only: cu_ntiedtke_run, & + cu_ntiedtke_init + use cu_ntiedtke_common + use cu_ntiedtke_post,only: cu_ntiedtke_post_run + use cu_ntiedtke_pre,only: cu_ntiedtke_pre_run -! modifications made to sourcecode: -! * used preprocessing option to replace module_model_constants with mpas_atmphys_constants; used preprocessing -! option to include the horizontal dependence of the array znu. -! Laura D. Fowler (laura@ucar.edu) / 2016-09-19. -! * added the three corrections available from module_cu_ntiedtke.F available in the WRF github repository Z(not -! in the released version WRF 3.8.1. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-18. + implicit none + private + public:: cu_ntiedtke_driver, & + ntiedtkeinit -!================================================================================================================= -!----------------------------------------------------------------------- -! -!wrf:model_layer:physics -! -!####################tiedtke scheme######################### -! m.tiedtke e.c.m.w.f. 1989 -! j.morcrette 1992 -!-------------------------------------------- -! modifications -! C. zhang & Yuqing Wang 2011-2014 -! -! modified from IPRC IRAM - yuqing wang, university of hawaii -! & ICTP REGCM4.4 -! -! The current version is stable. There are many updates to the old Tiedtke scheme (cu_physics=6) -! update notes: -! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. -! the major differences to the old Tiedtke (cu_physics=6) scheme are, -! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; -! Bechtold et al. 2004, 2008, 2014). -! (b) Non-equilibrium situations are considered in the closure for deep convection -! (Bechtold et al. 2014). -! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). -! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). -! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). -! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; -! Wu and Yanai 1994) -! -! other refenrence: tiedtke (1989, mwr, 117, 1779-1800) -! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 -! -!########################################################### - -module module_cu_ntiedtke - -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -#if defined(mpas) - use mpas_atmphys_constants, only: rd=>R_d, rv=>R_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g=>gravity -#else - use module_model_constants, only:rd=>r_d, rv=>r_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g -#endif - implicit none - real,private :: rcpd,vtmpc1,tmelt, & - c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg + contains - real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice - real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon - integer,private :: momtrans - parameter( & - rcpd=1.0/cpd, & - tmelt=273.16, & - zrg=1.0/g, & - c1es=610.78, & - c2es=c1es*rd/rv, & - c3les=17.2693882, & - c3ies=21.875, & - c4les=35.86, & - c4ies=7.66, & - c5les=c3les*(tmelt-c4les), & - c5ies=c3ies*(tmelt-c4ies), & - r5alvcp=c5les*alv*rcpd, & - r5alscp=c5ies*als*rcpd, & - ralvdcp=alv*rcpd, & - ralsdcp=als*rcpd, & - ralfdcp=alf*rcpd, & - rtwat=tmelt, & - rtber=tmelt-5., & - rtice=tmelt-23., & - vtmpc1=rv/rd-1.0 ) -! -! entrdd: average entrainment & detrainment rate for downdrafts -! ------ -! - parameter(entrdd = 2.0e-4) -! -! cmfcmax: maximum massflux value allowed for updrafts etc -! ------- -! - parameter(cmfcmax = 1.0) -! -! cmfcmin: minimum massflux value (for safety) -! ------- -! - parameter(cmfcmin = 1.e-10) -! -! cmfdeps: fractional massflux for downdrafts at lfs -! ------- -! - parameter(cmfdeps = 0.30) - -! zdnoprc: deep cloud is thicker than this height (Unit:Pa) -! - parameter(zdnoprc = 2.0e4) -! ------- -! -! cprcon: coefficient from cloud water to rain water -! - parameter(cprcon = 1.4e-3) -! ------- -! -! momtrans: momentum transport method -! ( 1 = IFS40r1 method; 2 = new method ) -! - parameter(momtrans = 2 ) -! ------- -! - logical :: isequil -! isequil: representing equilibrium and nonequilibrium convection -! ( .false. [default]; .true. [experimental]. Ref. Bechtold et al. 2014 JAS ) -! - parameter(isequil = .true. ) -! -!-------------------- -! switches for deep, mid, shallow convections, downdraft, and momentum transport -! ------------------ - logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv - parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) -!-------------------- -!#################### end of variables definition########################## -!----------------------------------------------------------------------- -! -contains -!----------------------------------------------------------------------- - subroutine cu_ntiedtke( & - dt,itimestep,stepcu & - ,raincv,pratec,qfx,hfx & - ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & - ,qvften,thften & - ,dz8w,pcps,p8w,xland,cu_act_flag,dx & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,rthcuten,rqvcuten,rqccuten,rqicuten & - ,rucuten, rvcuten & - ,f_qv ,f_qc ,f_qr ,f_qi ,f_qs & - ) -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- +!================================================================================================================= + subroutine cu_ntiedtke_driver( & + dt,itimestep,stepcu & + ,raincv,pratec,qfx,hfx & + ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & + ,qvften,thften & + ,dz8w,pcps,p8w,xland,cu_act_flag,dx & + ,f_qc,f_qi & + ,grav,xlf,xls,xlv,rd,rv,cp & + ,rthcuten,rqvcuten,rqccuten,rqicuten & + ,rucuten,rvcuten & + ,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) !-- th3d 3d potential temperature (k) @@ -203,3658 +82,274 @@ subroutine cu_ntiedtke( & !-- jte end index for j in tile !-- kts start index for k in tile !-- kte end index for k in tile -!------------------------------------------------------------------- - integer, intent(in) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - itimestep, & - stepcu - - real, intent(in) :: & - dt - real, dimension(ims:ime, jms:jme), intent(in) :: & - dx - - real, dimension(ims:ime, jms:jme), intent(in) :: & - xland - - real, dimension(ims:ime, jms:jme), intent(inout) :: & - raincv, pratec - - logical, dimension(ims:ime,jms:jme), intent(inout) :: & - cu_act_flag - - - real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: & - dz8w, & - pcps, & - p8w, & - pi3d, & - qc3d, & - qvften, & - thften, & - qi3d, & - qv3d, & - rho3d, & - t3d, & - u3d, & - v3d, & - w - real, dimension(ims:ime, jms:jme) :: & - qfx, & - hfx - -!--------------------------- optional vars ---------------------------- - - real, dimension(ims:ime, kms:kme, jms:jme), & - optional, intent(inout) :: & - rqccuten, & - rqicuten, & - rqvcuten, & - rthcuten, & - rucuten, & - rvcuten - -! -! flags relating to the optional tendency arrays declared above -! models that carry the optional tendencies will provdide the -! optional arguments at compile time; these flags all the model -! 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 - -!--------------------------- local vars ------------------------------ - real :: & - delt, & - rdelt - - real , dimension(its:ite) :: & - rcs, & - rn, & - evap, & - heatflux - integer , dimension(its:ite) :: slimsk - - - real , dimension(its:ite, kts:kte+1) :: & - prsi, & - ghti, & - zi - - real , dimension(its:ite, kts:kte) :: & - dot, & - prsl, & - q1, & - q2, & - q3, & - q1b, & - t1b, & - q11, & - q12, & - t1, & - u1, & - v1, & - zl, & - omg, & - ghtl - - integer, dimension(its:ite) :: & - kbot, & - ktop - - integer :: & - i, & - im, & - j, & - k, & - km, & - kp, & - kx, & - kx1 - -!-------other local variables---- - integer :: zz -!----------------------------------------------------------------------- -! -! -!*** check to see if this is a convection timestep -! - -!----------------------------------------------------------------------- - do j=jts,jte - do i=its,ite - cu_act_flag(i,j)=.true. - enddo - enddo - - im=ite-its+1 - kx=kte-kts+1 - kx1=kx+1 - delt=dt*stepcu - rdelt=1./delt - -!------------- j loop (outer) -------------------------------------------------- - - do j=jts,jte - -! --------------- compute zi and zl ----------------------------------------- - do i=its,ite - zi(i,kts)=0.0 - enddo -! - do k=kts,kte - do i=its,ite - zi(i,k+1)=zi(i,k)+dz8w(i,k,j) - enddo - enddo -! - do k=kts,kte - do i=its,ite - zl(i,k)=0.5*(zi(i,k)+zi(i,k+1)) - enddo - enddo - -! --------------- end compute zi and zl ------------------------------------- - do i=its,ite - slimsk(i)=int(abs(xland(i,j)-2.)) - enddo - - do k=kts,kte - kp=k+1 - do i=its,ite - dot(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) - enddo - enddo - - do k=kts,kte - zz = kte+1-k - do i=its,ite - u1(i,zz)=u3d(i,k,j) - v1(i,zz)=v3d(i,k,j) - t1(i,zz)=t3d(i,k,j) - q1(i,zz)=qv3d(i,k,j) - if(itimestep == 1) then - q1b(i,zz)=0. - t1b(i,zz)=0. - else - q1b(i,zz)=qvften(i,k,j) - t1b(i,zz)=thften(i,k,j) - endif - q2(i,zz)=qc3d(i,k,j) - q3(i,zz)=qi3d(i,k,j) - omg(i,zz)=dot(i,k) - ghtl(i,zz)=zl(i,k) - prsl(i,zz) = pcps(i,k,j) - enddo - enddo - - do k=kts,kte+1 - zz = kte+2-k - do i=its,ite - ghti(i,zz) = zi(i,k) - prsi(i,zz) = p8w(i,k,j) - enddo - enddo -! - do i=its,ite - evap(i) = qfx(i,j) - heatflux(i)= hfx(i,j) - enddo -! -!######################################################################## - call tiecnvn(u1,v1,t1,q1,q2,q3,q1b,t1b,ghtl,ghti,omg,prsl,prsi,evap,heatflux, & - rn,slimsk,im,kx,kx1,delt,dx) - - do i=its,ite - raincv(i,j)=rn(i)/stepcu - pratec(i,j)=rn(i)/(stepcu * dt) - enddo - - do k=kts,kte - zz = kte+1-k - do i=its,ite - rthcuten(i,k,j)=(t1(i,zz)-t3d(i,k,j))/pi3d(i,k,j)*rdelt - rqvcuten(i,k,j)=(q1(i,zz)-qv3d(i,k,j))*rdelt - rucuten(i,k,j) =(u1(i,zz)-u3d(i,k,j))*rdelt - rvcuten(i,k,j) =(v1(i,zz)-v3d(i,k,j))*rdelt - enddo - enddo - - if(present(rqccuten))then - if ( f_qc ) then - do k=kts,kte - zz = kte+1-k - do i=its,ite - rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt - enddo +!----------------------------------------------------------------------------------------------------------------- + +!--- input arguments: + logical,intent(in),optional:: f_qc,f_qi + + 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,stepcu + + real(kind=kind_phys),intent(in):: cp,grav,rd,rv,xlf,xls,xlv + + real(kind=kind_phys),intent(in):: dt + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: dx,hfx,qfx,xland + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + pcps, & + p8w, & + pi3d, & + qc3d, & + qvften, & + thften, & + qi3d, & + qv3d, & + rho3d, & + t3d, & + u3d, & + v3d, & + w + +!--- inout arguments: + logical,intent(inout),dimension(ims:ime,jms:jme):: cu_act_flag + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: raincv, pratec + + real(kind=kind_phys),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + rqccuten, & + rqicuten, & + rqvcuten, & + rthcuten, & + rucuten, & + rvcuten + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + +!--- local variables and arrays: + integer:: i,im,j,k,kx,kx1 + integer,dimension(its:ite):: slimsk + + real(kind=kind_phys):: delt + real(kind=kind_phys),dimension(its:ite):: rn + real(kind=kind_phys),dimension(its:ite,kts:kte):: prsl,omg,ghtl + real(kind=kind_phys),dimension(its:ite,kts:kte):: uf,vf,tf,qvf,qcf,qif + real(kind=kind_phys),dimension(its:ite,kts:kte):: qvftenz,thftenz + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: prsi,ghti,zi + + real(kind=kind_phys),dimension(its:ite):: dx_hv,hfx_hv,qfx_hv,xland_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: dz_hv,pi_hv,prsl_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,rho_hv,t_hv,u_hv,v_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: qvften_hv,thften_hv + real(kind=kind_phys),dimension(its:ite,kts:kte+1):: prsi_hv,w_hv + + real(kind=kind_phys),dimension(its:ite):: raincv_hv,pratec_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: rthcuten_hv,rqvcuten_hv,rqccuten_hv,rqicuten_hv, & + rucuten_hv,rvcuten_hv + +!----------------------------------------------------------------------------------------------------------------- + + errmsg = ' ' + errflg = 0 + + 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 , & + errflg = errflg & + ) + + do j = jts,jte + do i = its,ite + cu_act_flag(i,j)=.true. + enddo + enddo + + do j = jts,jte + + do i = its,ite + dx_hv(i) = dx(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + xland_hv(i) = xland(i,j) + enddo + + do k = kts,kte + do i = its,ite + dz_hv(i,k) = dz8w(i,k,j) + pi_hv(i,k) = pi3d(i,k,j) + prsl_hv(i,k) = pcps(i,k,j) + qv_hv(i,k) = qv3d(i,k,j) + qc_hv(i,k) = qc3d(i,k,j) + qi_hv(i,k) = qi3d(i,k,j) + rho_hv(i,k) = rho3d(i,k,j) + t_hv(i,k) = t3d(i,k,j) + u_hv(i,k) = u3d(i,k,j) + v_hv(i,k) = v3d(i,k,j) + + qvften_hv(i,k) = qvften(i,k,j) + thften_hv(i,k) = thften(i,k,j) + enddo + enddo + do k = kts,kte+1 + do i = its,ite + prsi_hv(i,k) = p8w(i,k,j) + w_hv(i,k) = w(i,k,j) + enddo + enddo + + call cu_ntiedtke_pre_run( & + its = its , ite = ite , kts = kts , kte = kte , & + im = im , kx = kx , kx1 = kx1 , itimestep = itimestep , & + stepcu = stepcu , dt = dt , grav = grav , xland = xland_hv , & + dz = dz_hv , pres = prsl_hv , presi = prsi_hv , t = t_hv , & + rho = rho_hv , qv = qv_hv , qc = qc_hv , qi = qi_hv , & + u = u_hv , v = v_hv , w = w_hv , qvften = qvften_hv , & + thften = thften_hv , qvftenz = qvftenz , thftenz = thftenz , slimsk = slimsk , & + delt = delt , prsl = prsl , ghtl = ghtl , tf = tf , & + qvf = qvf , qcf = qcf , qif = qif , uf = uf , & + vf = vf , prsi = prsi , ghti = ghti , omg = omg , & + errmsg = errmsg , errflg = errflg & + ) + + call cu_ntiedtke_run( & + pu = uf , pv = vf , pt = tf , pqv = qvf , & + pqc = qcf , pqi = qif , pqvf = qvftenz , ptf = thftenz , & + poz = ghtl , pzz = ghti , pomg = omg , pap = prsl , & + paph = prsi , evap = qfx_hv , hfx = hfx_hv , zprecc = rn , & + lndj = slimsk , lq = im , km = kx , km1 = kx1 , & + dt = delt , dx = dx_hv , errmsg = errmsg , errflg = errflg & + ) + + call cu_ntiedtke_post_run( & + its = its , ite = ite , kts = kts , kte = kte , & + stepcu = stepcu , dt = dt , exner = pi_hv , qv = qv_hv , & + qc = qc_hv , qi = qi_hv , t = t_hv , u = u_hv , & + v = v_hv , qvf = qvf , qcf = qcf , qif = qif , & + tf = tf , uf = uf , vf = vf , rn = rn , & + raincv = raincv_hv , pratec = pratec_hv , rthcuten = rthcuten_hv , rqvcuten = rqvcuten_hv , & + rqccuten = rqccuten_hv , rqicuten = rqicuten_hv , rucuten = rucuten_hv , rvcuten = rvcuten_hv , & + errmsg = errmsg , errflg = errflg & + ) + + do i = its,ite + raincv(i,j) = raincv_hv(i) + pratec(i,j) = pratec_hv(i) + enddo + + do k = kts,kte + do i = its,ite + rucuten(i,k,j) = rucuten_hv(i,k) + rvcuten(i,k,j) = rvcuten_hv(i,k) + rthcuten(i,k,j) = rthcuten_hv(i,k) + rqvcuten(i,k,j) = rqvcuten_hv(i,k) + enddo + enddo + + if(present(rqccuten))then + if(f_qc) then + do k = kts,kte + do i = its,ite + rqccuten(i,k,j) = rqccuten_hv(i,k) + enddo enddo - endif - endif - - if(present(rqicuten))then - if ( f_qi ) then - do k=kts,kte - zz = kte+1-k - do i=its,ite - rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt - enddo + endif + endif + + if(present(rqicuten))then + if(f_qi) then + do k = kts,kte + do i = its,ite + rqicuten(i,k,j) = rqicuten_hv(i,k) + enddo enddo - endif - endif - - - enddo - - end subroutine cu_ntiedtke - -!==================================================================== - subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & - rucuten,rvcuten,rthften,rqvften, & - restart,p_qc,p_qi,p_first_scalar, & - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte) -!-------------------------------------------------------------------- - implicit none -!-------------------------------------------------------------------- - logical , intent(in) :: allowed_to_read,restart - integer , intent(in) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - integer , intent(in) :: p_first_scalar, p_qi, p_qc - - real, dimension( ims:ime , kms:kme , jms:jme ) , intent(out) :: & - rthcuten, & - rqvcuten, & - rqccuten, & - rqicuten, & - rucuten,rvcuten,& - rthften,rqvften - - 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 - rthcuten(i,k,j)=0. - rqvcuten(i,k,j)=0. - rucuten(i,k,j)=0. - rvcuten(i,k,j)=0. - enddo - enddo - enddo - - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - rthften(i,k,j)=0. - rqvften(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - if (p_qc .ge. p_first_scalar) then - do j=jts,jtf - do k=kts,ktf - do i=its,itf - rqccuten(i,k,j)=0. - enddo - enddo - enddo - endif - - if (p_qi .ge. p_first_scalar) then - do j=jts,jtf - do k=kts,ktf - do i=its,itf - rqicuten(i,k,j)=0. - enddo - enddo - enddo - endif - endif - - end subroutine ntiedtkeinit - -!----------------------------------------------------------------- -! level 1 subroutine 'tiecnvn' -!----------------------------------------------------------------- - subroutine tiecnvn(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & - & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx) -!----------------------------------------------------------------- -! this is the interface between the model and the mass -! flux convection module -!----------------------------------------------------------------- - implicit none -! - real pu(lq,km), pv(lq,km), pt(lq,km), pqv(lq,km) - real poz(lq,km), pomg(lq,km), evap(lq), zprecc(lq) - real pzz(lq,km1) - - real pum1(lq,km), pvm1(lq,km), ztt(lq,km), & - & ptte(lq,km), pqte(lq,km), pvom(lq,km), pvol(lq,km), & - & pverv(lq,km), pgeo(lq,km), pap(lq,km), paph(lq,km1) - real pqhfl(lq), zqq(lq,km), & - & prsfc(lq), pssfc(lq), pcte(lq,km), & - & phhfl(lq), hfx(lq), pgeoh(lq,km1) - real ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km), & - & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), & - & zqsat(lq,km), pqc(lq,km), pqi(lq,km), zrain(lq) - real pqvf(lq,km), ptf(lq,km) - real dx(lq) - - integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) - logical locum(lq) -! - real ztmst,fliq,fice,ztc,zalf,tt - integer i,j,k,lq,km,km1 - real dt,ztpp1 - real zew,zqs,zcor -! - ztmst=dt -! -! masv flux diagnostics. -! - do j=1,lq - zrain(j)=0.0 - locum(j)=.false. - prsfc(j)=0.0 - pssfc(j)=0.0 - pqhfl(j)=evap(j) - phhfl(j)=hfx(j) - pgeoh(j,km1)=g*pzz(j,km1) - end do -! -! convert model variables for mflux scheme -! - do k=1,km - do j=1,lq - pcte(j,k)=0.0 - pvom(j,k)=0.0 - pvol(j,k)=0.0 - ztp1(j,k)=pt(j,k) - zqp1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) - pum1(j,k)=pu(j,k) - pvm1(j,k)=pv(j,k) - pverv(j,k)=pomg(j,k) - pgeo(j,k)=g*poz(j,k) - pgeoh(j,k)=g*pzz(j,k) - tt=ztp1(j,k) - zew = foeewm(tt) - zqs = zew/pap(j,k) - zqs = min(0.5,zqs) - zcor = 1./(1.-vtmpc1*zqs) - zqsat(j,k)=zqs*zcor - pqte(j,k)=pqvf(j,k) - zqq(j,k) =pqte(j,k) - ptte(j,k)=ptf(j,k) - ztt(j,k) =ptte(j,k) - end do - end do -! -!----------------------------------------------------------------------- -!* 2. call 'cumastrn'(master-routine for cumulus parameterization) -! - call cumastrn & - & (lq, km, km1, km-1, ztp1, & - & zqp1, pum1, pvm1, pverv, zqsat,& - & pqhfl, ztmst, pap, paph, pgeo, & - & ptte, pqte, pvom, pvol, prsfc,& - & pssfc, locum, & - & ktype, icbot, ictop, ztu, zqu, & - & zlu, zlude, zmfu, zmfd, zrain,& - & pcte, phhfl, lndj, pgeoh, dx) -! -! to include the cloud water and cloud ice detrained from convection -! - do k=1,km - do j=1,lq - if(pcte(j,k).gt.0.) then - fliq=foealfa(ztp1(j,k)) - fice=1.0-fliq - pqc(j,k)=pqc(j,k)+fliq*pcte(j,k)*ztmst - pqi(j,k)=pqi(j,k)+fice*pcte(j,k)*ztmst - endif - end do - end do -! - do k=1,km - do j=1,lq - pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(j,k))*ztmst - zqp1(j,k)=zqp1(j,k)+(pqte(j,k)-zqq(j,k))*ztmst - pqv(j,k)=zqp1(j,k)/(1.0-zqp1(j,k)) - end do - end do - - do j=1,lq - zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) - end do - - if (lmfdudv) then - do k=1,km - do j=1,lq - pu(j,k)=pu(j,k)+pvom(j,k)*ztmst - pv(j,k)=pv(j,k)+pvol(j,k)*ztmst - end do - end do - endif -! - return - end subroutine tiecnvn - -!############################################################# -! -! level 2 subroutines -! -!############################################################# -!*********************************************************** -! subroutine cumastrn -!*********************************************************** - subroutine cumastrn & - & (klon, klev, klevp1, klevm1, pten, & - & pqen, puen, pven, pverv, pqsen,& - & pqhfl, ztmst, pap, paph, pgeo, & - & ptte, pqte, pvom, pvol, prsfc,& - & pssfc, ldcum, & - & ktype, kcbot, kctop, ptu, pqu,& - & plu, plude, pmfu, pmfd, prain,& - & pcte, phhfl, lndj, zgeoh, dx) - implicit none -! -!***cumastrn* master routine for cumulus massflux-scheme -! m.tiedtke e.c.m.w.f. 1986/1987/1989 -! modifications -! y.wang i.p.r.c 2001 -! c.zhang 2012 -!***purpose -! ------- -! this routine computes the physical tendencies of the -! prognostic variables t,q,u and v due to convective processes. -! processes considered are: convective fluxes, formation of -! precipitation, evaporation of falling rain below cloud base, -! saturated cumulus downdrafts. -!***method -! ------ -! parameterization is done using a massflux-scheme. -! (1) define constants and parameters -! (2) specify values (t,q,qs...) at half levels and -! initialize updraft- and downdraft-values in 'cuinin' -! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, -! and specify cloud base massflux -! (4) do cloud ascent in 'cuascn' in absence of downdrafts -! (5) do downdraft calculations: -! (a) determine values at lfs in 'cudlfsn' -! (b) determine moist descent in 'cuddrafn' -! (c) recalculate cloud base massflux considering the -! effect of cu-downdrafts -! (6) do final adjusments to convective fluxes in 'cuflxn', -! do evaporation in subcloud layer -! (7) calculate increments of t and q in 'cudtdqn' -! (8) calculate increments of u and v in 'cududvn' -!***externals. -! ---------- -! cuinin: initializes values at vertical grid used in cu-parametr. -! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus -! cuascn: cloud ascent for entraining plume -! cudlfsn: determines values at lfs for downdrafts -! cuddrafn:does moist descent for cumulus downdrafts -! cuflxn: final adjustments to convective fluxes (also in pbl) -! cudqdtn: updates tendencies for t and q -! cududvn: updates tendencies for u and v -!***switches. -! -------- -! lmfmid=.t. midlevel convection is switched on -! lmfdd=.t. cumulus downdrafts switched on -! lmfdudv=.t. cumulus friction switched on -!*** -! model parameters (defined in subroutine cuparam) -! ------------------------------------------------ -! entrdd entrainment rate for cumulus downdrafts -! cmfcmax maximum massflux value allowed for -! cmfcmin minimum massflux value (for safety) -! cmfdeps fractional massflux for downdrafts at lfs -! cprcon coefficient for conversion from cloud water to rain -!***reference. -! ---------- -! paper on massflux scheme (tiedtke,1989) -!----------------------------------------------------------------- - integer klev,klon,klevp1,klevm1 - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & ptte(klon,klev), pqte(klon,klev),& - & pvom(klon,klev), pvol(klon,klev),& - & pqsen(klon,klev), pgeo(klon,klev),& - & pap(klon,klev), paph(klon,klevp1),& - & pverv(klon,klev), pqhfl(klon),& - & phhfl(klon) - real ptu(klon,klev), pqu(klon,klev),& - & plu(klon,klev), plude(klon,klev),& - & pmfu(klon,klev), pmfd(klon,klev),& - & prain(klon),& - & prsfc(klon), pssfc(klon) - real ztenh(klon,klev), zqenh(klon,klev),& - & zgeoh(klon,klevp1), zqsenh(klon,klev),& - & ztd(klon,klev), zqd(klon,klev),& - & zmfus(klon,klev), zmfds(klon,klev),& - & zmfuq(klon,klev), zmfdq(klon,klev),& - & zdmfup(klon,klev), zdmfdp(klon,klev),& - & zmful(klon,klev), zrfl(klon),& - & zuu(klon,klev), zvu(klon,klev),& - & zud(klon,klev), zvd(klon,klev),& - & zlglac(klon,klev) - real pmflxr(klon,klevp1), pmflxs(klon,klevp1) - real zhcbase(klon),& - & zmfub(klon), zmfub1(klon),& - & zdhpbl(klon) - real zsfl(klon), zdpmel(klon,klev),& - & pcte(klon,klev), zcape(klon),& - & zcape1(klon), zcape2(klon),& - & ztauc(klon), ztaubl(klon),& - & zheat(klon) - real wup(klon), zdqcv(klon) - real wbase(klon), zmfuub(klon) - real upbl(klon) - real dx(klon) - real pmfude_rate(klon,klev), pmfdde_rate(klon,klev) - real zmfuus(klon,klev), zmfdus(klon,klev) - real zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) - real zmfuvb(klon),zsum12(klon),zsum22(klon) - integer ilab(klon,klev), idtop(klon),& - & ictop0(klon), ilwmin(klon) - integer kdpl(klon) - integer kcbot(klon), kctop(klon),& - & ktype(klon), lndj(klon) - logical ldcum(klon) - logical loddraf(klon), llo1, llo2(klon) - -! local varaiables - real zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax - real zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat - real zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed - integer jl,jk,ik - integer ikb,ikt,icum,itopm2 - real ztmst,ztau,zerate,zderate,zmfa - real zmfs(klon),pmean(klev),zlon - real zduten,zdvten,ztdis,pgf_u,pgf_v -!------------------------------------------- -! 1. specify constants and parameters -!------------------------------------------- - zcons=1./(g*ztmst) - zcons2=3./(g*ztmst) - -!-------------------------------------------------------------- -!* 2. initialize values at vertical grid points in 'cuini' -!-------------------------------------------------------------- - call cuinin & - & (klon, klev, klevp1, klevm1, pten, & - & pqen, pqsen, puen, pven, pverv,& - & pgeo, paph, zgeoh, ztenh, zqenh,& - & zqsenh, ilwmin, ptu, pqu, ztd, & - & zqd, zuu, zvu, zud, zvd, & - & pmfu, pmfd, zmfus, zmfds, zmfuq,& - & zmfdq, zdmfup, zdmfdp, zdpmel, plu, & - & plude, ilab) - -!---------------------------------- -!* 3.0 cloud base calculations -!---------------------------------- -!* (a) determine cloud base values in 'cutypen', -! and the cumulus type 1 or 2 -! ------------------------------------------- - call cutypen & - & ( klon, klev, klevp1, klevm1, pqen,& - & ztenh, zqenh, zqsenh, zgeoh, paph,& - & phhfl, pqhfl, pgeo, pqsen, pap,& - & pten, lndj, ptu, pqu, ilab,& - & ldcum, kcbot, ictop0, ktype, wbase, plu, kdpl) - -!* (b) assign the first guess mass flux at cloud base -! ------------------------------------------ - do jl=1,klon - zdhpbl(jl)=0.0 - upbl(jl) = 0.0 - idtop(jl)=0 - end do - - do jk=2,klev - do jl=1,klon - if(jk.ge.kcbot(jl) .and. ldcum(jl)) then - zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& - & *(paph(jl,jk+1)-paph(jl,jk)) - if(lndj(jl) .eq. 0) then - wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) - upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) - end if - end if - end do - end do - - do jl=1,klon - if(ldcum(jl)) then - ikb=kcbot(jl) - zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 - if(ktype(jl) == 1) then - zmfub(jl)= 0.1*zmfmax - else if ( ktype(jl) == 2 ) then - zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) - zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) - zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe - zdh = g*max(zdh,1.e5*zdqmin) - if ( zdhpbl(jl) > 0. ) then - zmfub(jl) = zdhpbl(jl)/zdh - zmfub(jl) = min(zmfub(jl),zmfmax) - else - zmfub(jl) = 0.1*zmfmax - ldcum(jl) = .false. - end if - end if - else - zmfub(jl) = 0. - end if - end do -!------------------------------------------------------ -!* 4.0 determine cloud ascent for entraining plume -!------------------------------------------------------ -!* (a) do ascent in 'cuasc'in absence of downdrafts -!---------------------------------------------------------- - call cuascn & - & (klon, klev, klevp1, klevm1, ztenh,& - & zqenh, puen, pven, pten, pqen,& - & pqsen, pgeo, zgeoh, pap, paph,& - & pqte, pverv, ilwmin, ldcum, zhcbase,& - & ktype, ilab, ptu, pqu, plu,& - & zuu, zvu, pmfu, zmfub,& - & zmfus, zmfuq, zmful, plude, zdmfup,& - & kcbot, kctop, ictop0, icum, ztmst,& - & zqsenh, zlglac, lndj, wup, wbase, kdpl, pmfude_rate ) - -!* (b) check cloud depth and change entrainment rate accordingly -! calculate precipitation rate (for downdraft calculation) -!------------------------------------------------------------------ - do jl=1,klon - if ( ldcum(jl) ) then - ikb = kcbot(jl) - itopm2 = kctop(jl) - zpbmpt = paph(jl,ikb) - paph(jl,itopm2) - if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 - if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 - ictop0(jl) = kctop(jl) - end if - zrfl(jl)=zdmfup(jl,1) - end do - - do jk=2,klev - do jl=1,klon - zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) - end do - end do - - do jk = 1,klev - do jl = 1,klon - pmfd(jl,jk) = 0. - zmfds(jl,jk) = 0. - zmfdq(jl,jk) = 0. - zdmfdp(jl,jk) = 0. - zdpmel(jl,jk) = 0. - end do - end do - -!----------------------------------------- -!* 6.0 cumulus downdraft calculations -!----------------------------------------- - if(lmfdd) then -!* (a) determine lfs in 'cudlfsn' -!-------------------------------------- - call cudlfsn & - & (klon, klev,& - & kcbot, kctop, lndj, ldcum, & - & ztenh, zqenh, puen, pven, & - & pten, pqsen, pgeo, & - & zgeoh, paph, ptu, pqu, plu, & - & zuu, zvu, zmfub, zrfl, & - & ztd, zqd, zud, zvd, & - & pmfd, zmfds, zmfdq, zdmfdp, & - & idtop, loddraf) -!* (b) determine downdraft t,q and fluxes in 'cuddrafn' -!------------------------------------------------------------ - call cuddrafn & - & ( klon, klev, loddraf, & - & ztenh, zqenh, puen, pven, & - & pgeo, zgeoh, paph, zrfl, & - & ztd, zqd, zud, zvd, pmfu, & - & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate ) -!----------------------------------------------------------- - end if -! -!----------------------------------------------------------------------- -!* 6.0 closure and clean work -! ------ -!-- 6.1 recalculate cloud base massflux from a cape closure -! for deep convection (ktype=1) -! - do jl=1,klon - if(ldcum(jl) .and. ktype(jl) .eq. 1) then - ikb = kcbot(jl) - ikt = kctop(jl) - zheat(jl)=0.0 - zcape(jl)=0.0 - zcape1(jl)=0.0 - zcape2(jl)=0.0 - zmfub1(jl)=zmfub(jl) - - ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & - ((2.+ min(15.0,wup(jl)))*g) - if(lndj(jl) .eq. 0) then - upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)) - ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl)) - ztaubl(jl) = min(300., ztaubl(jl)) - else - ztaubl(jl) = ztauc(jl) - end if - end if - end do -! - do jk = 1 , klev - do jl = 1 , klon - llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 - if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then - ikb = kcbot(jl) - zdz = pgeo(jl,jk-1)-pgeo(jl,jk) - zdp = pap(jl,jk)-pap(jl,jk-1) - zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & - ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & - (g*(pmfu(jl,jk)+pmfd(jl,jk))) - zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & - vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp - end if - - if ( llo1 .and. jk >= kcbot(jl) ) then - if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then - zdp = paph(jl,jk+1)-paph(jl,jk) - zcape2(jl) = zcape2(jl) + ztaubl(jl)* & - ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp - end if - end if - end do - end do - - do jl=1,klon - if(ldcum(jl).and.ktype(jl).eq.1) then - ikb = kcbot(jl) - ikt = kctop(jl) - ztau = ztauc(jl) * (1.+1.33e-5*dx(jl)) - ztau = max(ztmst,ztau) - ztau = max(360.,ztau) - ztau = min(10800.,ztau) - if(isequil) then - zcape2(jl)= max(0.,zcape2(jl)) - zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) - else - zcape(jl) = max(0.,min(zcape1(jl),5000.)) - end if - zheat(jl) = max(1.e-4,zheat(jl)) - zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) - zmfub1(jl) = max(zmfub1(jl),0.001) - zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 - zmfub1(jl)=min(zmfub1(jl),zmfmax) - end if - end do -! -!* 6.2 recalculate convective fluxes due to effect of -! downdrafts on boundary layer moist static energy budget (ktype=2) -!-------------------------------------------------------- - do jl=1,klon - if(ldcum(jl) .and. ktype(jl) .eq. 2) then - ikb=kcbot(jl) - if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then - zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) - else - zeps=0. - endif - zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & - & zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) - zdqmin=max(0.01*zqenh(jl,ikb),cmfcmin) - zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 -! using moist static engergy closure instead of moisture closure - zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & - & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe - zdh=g*max(zdh,1.e5*zdqmin) - if(zdhpbl(jl).gt.0.)then - zmfub1(jl)=zdhpbl(jl)/zdh - else - zmfub1(jl) = zmfub(jl) - end if - zmfub1(jl) = min(zmfub1(jl),zmfmax) - end if - -!* 6.3 mid-level convection - nothing special -!--------------------------------------------------------- - if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then - zmfub1(jl) = zmfub(jl) - end if - - end do - -!* 6.4 scaling the downdraft mass flux -!--------------------------------------------------------- - do jk=1,klev - do jl=1,klon - if( ldcum(jl) ) then - zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) - pmfd(jl,jk)=pmfd(jl,jk)*zfac - zmfds(jl,jk)=zmfds(jl,jk)*zfac - zmfdq(jl,jk)=zmfdq(jl,jk)*zfac - zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac - end if - end do - end do - -!* 6.5 scaling the updraft mass flux -! -------------------------------------------------------- - do jl = 1,klon - if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) - end do - do jk = 2 , klev - do jl = 1,klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - ikb = kcbot(jl) - if ( jk>ikb ) then - zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) - pmfu(jl,jk) = pmfu(jl,ikb)*zdz - end if - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then - zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) - end if - end if - end do - end do - do jk = 2 , klev - do jl = 1,klon - if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then - pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) - zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) - zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) - zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) - plude(jl,jk) = plude(jl,jk)*zmfs(jl) - pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) - end if - end do - end do - -!* 6.6 if ktype = 2, kcbot=kctop is not allowed -! --------------------------------------------------- - do jl = 1,klon - if ( ktype(jl) == 2 .and. & - kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then - ldcum(jl) = .false. - ktype(jl) = 0 - end if - end do - - if ( .not. lmfscv .or. .not. lmfpen ) then - do jl = 1,klon - llo2(jl) = .false. - if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & - (.not. lmfpen .and. ktype(jl) == 1) ) then - llo2(jl) = .true. - ldcum(jl) = .false. - end if - end do - end if - -!* 6.7 set downdraft mass fluxes to zero above cloud top -!---------------------------------------------------- - do jl = 1,klon - if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then - idtop(jl) = kctop(jl) + 1 - end if - end do - do jk = 2 , klev - do jl = 1,klon - if ( loddraf(jl) ) then - if ( jk < idtop(jl) ) then - pmfd(jl,jk) = 0. - zmfds(jl,jk) = 0. - zmfdq(jl,jk) = 0. - pmfdde_rate(jl,jk) = 0. - zdmfdp(jl,jk) = 0. - else if ( jk == idtop(jl) ) then - pmfdde_rate(jl,jk) = 0. - end if - end if - end do - end do -!---------------------------------------------------------- -!* 7.0 determine final convective fluxes in 'cuflx' -!---------------------------------------------------------- - call cuflxn & - & ( klon, klev, ztmst & - & , pten, pqen, pqsen, ztenh, zqenh & - & , paph, pap, zgeoh, lndj, ldcum & - & , kcbot, kctop, idtop, itopm2 & - & , ktype, loddraf & - & , pmfu, pmfd, zmfus, zmfds & - & , zmfuq, zmfdq, zmful, plude & - & , zdmfup, zdmfdp, zdpmel, zlglac & - & , prain, pmfdde_rate, pmflxr, pmflxs ) - -! some adjustments needed - do jl=1,klon - zmfs(jl) = 1. - zmfuub(jl)=0. - end do - do jk = 2 , klev - do jl = 1,klon - if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then - zmfmax = pmfu(jl,jk)*0.98 - if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then - zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk)) - end if - end if - end do - end do - - do jk = 2 , klev - do jl = 1 , klon - if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then - pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl) - zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl) - zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl) - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl) - zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk) - pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl) - zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl) - end if - end do - end do + endif + endif - do jk = 2 , klev - 1 - do jl = 1, klon - if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then - zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk) - if ( zerate < 0. ) then - pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate - end if - end if - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk) - if ( zerate < 0. ) then - pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate - end if - zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - & - pmflxr(jl,jk) - pmflxs(jl,jk) - zdmfdp(jl,jk) = 0. - end if - end do - end do + enddo -! avoid negative humidities at ddraught top - do jl = 1,klon - if ( loddraf(jl) ) then - jk = idtop(jl) - ik = min(jk+1,klev) - if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then - zmfdq(jl,jk) = 0.3*zmfdq(jl,ik) - end if - end if - end do + end subroutine cu_ntiedtke_driver -! avoid negative humidities near cloud top because gradient of precip flux -! and detrainment / liquid water flux are too large - do jk = 2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then - zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk)) - zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - & - zmfuq(jl,jk) - zmfdq(jl,jk) + & - zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk) - zmfa = (zmfa-plude(jl,jk))*zdz - if ( pqen(jl,jk)+zmfa < 0. ) then - plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz - end if - if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0. - end if - if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0. - if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0. - end do - end do - - do jl=1,klon - prsfc(jl) = pmflxr(jl,klev+1) - pssfc(jl) = pmflxs(jl,klev+1) - end do - -!---------------------------------------------------------------- -!* 8.0 update tendencies for t and q in subroutine cudtdq -!---------------------------------------------------------------- - call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & - ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & - zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & - zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) -!---------------------------------------------------------------- -!* 9.0 update tendencies for u and u in subroutine cududv -!---------------------------------------------------------------- - if(lmfdudv) then - do jk = klev-1 , 2 , -1 - ik = jk + 1 - do jl = 1,klon - if ( ldcum(jl) ) then - if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then - ikb = kdpl(jl) - zuu(jl,jk) = puen(jl,ikb-1) - zvu(jl,jk) = pven(jl,ikb-1) - else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then - zuu(jl,jk) = puen(jl,jk-1) - zvu(jl,jk) = pven(jl,jk-1) - end if - if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then - if(momtrans .eq. 1)then - zfac = 0. - if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. - if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. - zerate = pmfu(jl,jk) - pmfu(jl,ik) + & - (1.+zfac)*pmfude_rate(jl,jk) - zderate = (1.+zfac)*pmfude_rate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & - zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa - zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & - zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa - else - if(ktype(jl) == 1 .or. ktype(jl) == 3) then - pgf_u = -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& - pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) - pgf_v = -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& - pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) - else - pgf_u = 0. - pgf_v = 0. - end if - zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) - zderate = pmfude_rate(jl,jk) - zmfa = 1./max(cmfcmin,pmfu(jl,jk)) - zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & - zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa - zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & - zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa - end if - end if - end if - end do - end do - - if(lmfdd) then - do jk = 3 , klev - ik = jk - 1 - do jl = 1,klon - if ( ldcum(jl) ) then - if ( jk == idtop(jl) ) then - zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) - zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) - else if ( jk > idtop(jl) ) then - zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) - zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) - zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & - zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa - zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & - zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa - end if - end if - end do - end do - end if -! -------------------------------------------------- -! rescale massfluxes for stability in Momentum -!------------------------------------------------------------------------ - zmfs(:) = 1. - do jk = 2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons - if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then - zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) - end if - end if - end do - end do - do jk = 1 , klev - do jl = 1, klon - zmfuus(jl,jk) = pmfu(jl,jk) - zmfdus(jl,jk) = pmfd(jl,jk) - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) - zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) - end if - end do - end do -!* 9.1 update u and v in subroutine cududvn -!------------------------------------------------------------------- - do jk = 1 , klev - do jl = 1, klon - ztenu(jl,jk) = pvom(jl,jk) - ztenv(jl,jk) = pvol(jl,jk) - end do - end do - - call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & - ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & - zud,zvu,zvd,pvom,pvol) - -! calculate KE dissipation - do jl = 1, klon - zsum12(jl) = 0. - zsum22(jl) = 0. - end do - do jk = 1 , klev - do jl = 1, klon - zuv2(jl,jk) = 0. - if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then - zdz = (paph(jl,jk+1)-paph(jl,jk)) - zduten = pvom(jl,jk) - ztenu(jl,jk) - zdvten = pvol(jl,jk) - ztenv(jl,jk) - zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) - zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz - zsum12(jl) = zsum12(jl) - & - (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz - end if - end do - end do - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then - ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) - ptte(jl,jk) = ptte(jl,jk) + ztdis - end if - end do - end do - - end if - -!---------------------------------------------------------------------- -!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF -! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO -! --------------------------------------------------- - if ( .not. lmfscv .or. .not. lmfpen ) then - do jk = 2 , klev - do jl = 1, klon - if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then - ptu(jl,jk) = pten(jl,jk) - pqu(jl,jk) = pqen(jl,jk) - plu(jl,jk) = 0. - pmfude_rate(jl,jk) = 0. - pmfdde_rate(jl,jk) = 0. - end if - end do - end do - do jl = 1, klon - if ( llo2(jl) ) then - kctop(jl) = klev - 1 - kcbot(jl) = klev - 1 - end if - end do - end if - - return - end subroutine cumastrn - -!********************************************** -! level 3 subroutine cuinin -!********************************************** -! - subroutine cuinin & - & (klon, klev, klevp1, klevm1, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, paph, pgeoh, ptenh, pqenh,& - & pqsenh, klwmin, ptu, pqu, ptd,& - & pqd, puu, pvu, pud, pvd,& - & pmfu, pmfd, pmfus, pmfds, pmfuq,& - & pmfdq, pdmfup, pdmfdp, pdpmel, plu,& - & plude, klab) - implicit none -! m.tiedtke e.c.m.w.f. 12/89 -!***purpose -! ------- -! this routine interpolates large-scale fields of t,q etc. -! to half levels (i.e. grid for massflux scheme), -! and initializes values for updrafts and downdrafts -!***interface -! --------- -! this routine is called from *cumastr*. -!***method. -! -------- -! for extrapolation to half levels see tiedtke(1989) -!***externals -! --------- -! *cuadjtq* to specify qs at half levels -! ---------------------------------------------------------------- - integer klon,klev,klevp1,klevm1 - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & pqsen(klon,klev), pverv(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klevp1),& - & paph(klon,klevp1), ptenh(klon,klev),& - & pqenh(klon,klev), pqsenh(klon,klev) - real ptu(klon,klev), pqu(klon,klev),& - & ptd(klon,klev), pqd(klon,klev),& - & puu(klon,klev), pud(klon,klev),& - & pvu(klon,klev), pvd(klon,klev),& - & pmfu(klon,klev), pmfd(klon,klev),& - & pmfus(klon,klev), pmfds(klon,klev),& - & pmfuq(klon,klev), pmfdq(klon,klev),& - & pdmfup(klon,klev), pdmfdp(klon,klev),& - & plu(klon,klev), plude(klon,klev) - real zwmax(klon), zph(klon), & - & pdpmel(klon,klev) - integer klab(klon,klev), klwmin(klon) - logical loflag(klon) -! local variables - integer jl,jk - integer icall,ik - real zzs -!------------------------------------------------------------ -!* 1. specify large scale parameters at half levels -!* adjust temperature fields if staticly unstable -!* find level of maximum vertical velocity -! ----------------------------------------------------------- - do jk=2,klev - do jl=1,klon - ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & - & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd - pqenh(jl,jk) = pqen(jl,jk-1) - pqsenh(jl,jk)= pqsen(jl,jk-1) - zph(jl)=paph(jl,jk) - loflag(jl)=.true. - end do - - if ( jk >= klev-1 .or. jk < 2 ) cycle - ik=jk - icall=0 - call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) - do jl=1,klon - pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & - & +(pqsenh(jl,jk)-pqsen(jl,jk-1)) - pqenh(jl,jk)=max(pqenh(jl,jk),0.) - end do - end do - - do jl=1,klon - ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & - & pgeoh(jl,klev))*rcpd - pqenh(jl,klev)=pqen(jl,klev) - ptenh(jl,1)=pten(jl,1) - pqenh(jl,1)=pqen(jl,1) - klwmin(jl)=klev - zwmax(jl)=0. - end do - - do jk=klevm1,2,-1 - do jl=1,klon - zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & - & cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) - ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd - end do - end do - - do jk=klev,3,-1 - do jl=1,klon - if(pverv(jl,jk).lt.zwmax(jl)) then - zwmax(jl)=pverv(jl,jk) - klwmin(jl)=jk - end if - end do - end do -!----------------------------------------------------------- -!* 2.0 initialize values for updrafts and downdrafts -!----------------------------------------------------------- - do jk=1,klev - ik=jk-1 - if(jk.eq.1) ik=1 - do jl=1,klon - ptu(jl,jk)=ptenh(jl,jk) - ptd(jl,jk)=ptenh(jl,jk) - pqu(jl,jk)=pqenh(jl,jk) - pqd(jl,jk)=pqenh(jl,jk) - plu(jl,jk)=0. - puu(jl,jk)=puen(jl,ik) - pud(jl,jk)=puen(jl,ik) - pvu(jl,jk)=pven(jl,ik) - pvd(jl,jk)=pven(jl,ik) - klab(jl,jk)=0 - end do - end do - return - end subroutine cuinin - -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cutypen & - & ( klon, klev, klevp1, klevm1, pqen,& - & ptenh, pqenh, pqsenh, pgeoh, paph,& - & hfx, qfx, pgeo, pqsen, pap,& - & pten, lndj, cutu, cuqu, culab,& - & ldcum, cubot, cutop, ktype, wbase, culu, kdpl ) -! zhang & wang iprc 2011-2013 -!***purpose. -! -------- -! to produce first guess updraught for cu-parameterizations -! calculates condensation level, and sets updraught base variables and -! first guess cloud type -!***interface -! --------- -! this routine is called from *cumastr*. -! input are environm. values of t,q,p,phi at half levels. -! it returns cloud types as follows; -! ktype=1 for deep cumulus -! ktype=2 for shallow cumulus -!***method. -! -------- -! based on a simplified updraught equation -! partial(hup)/partial(z)=eta(h - hup) -! eta is the entrainment rate for test parcel -! h stands for dry static energy or the total water specific humidity -! references: christian jakob, 2003: a new subcloud model for -! mass-flux convection schemes -! influence on triggering, updraft properties, and model -! climate, mon.wea.rev. -! 131, 2765-2778 -! and -! ifs documentation - cy36r1,cy38r1 -!***input variables: -! ptenh [ztenh] - environment temperature on half levels. (cuini) -! pqenh [zqenh] - env. specific humidity on half levels. (cuini) -! pgeoh [zgeoh] - geopotential on half levels, (mssflx) -! paph - pressure of half levels. (mssflx) -! rho - density of the lowest model level -! qfx - net upward moisture flux at the surface (kg/m^2/s) -! hfx - net upward heat flux at the surface (w/m^2) -!***variables output by cutype: -! ktype - convection type - 1: penetrative (cumastr) -! 2: stratocumulus (cumastr) -! 3: mid-level (cuasc) -! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) -! ---------------------------------------------------------------- -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------- - integer klon, klev, klevp1, klevm1 - real ptenh(klon,klev), pqenh(klon,klev),& - & pqsen(klon,klev), pqsenh(klon,klev),& - & pgeoh(klon,klevp1), paph(klon,klevp1),& - & pap(klon,klev), pqen(klon,klev) - real pten(klon,klev) - real ptu(klon,klev),pqu(klon,klev),plu(klon,klev) - real pgeo(klon,klev) - integer klab(klon,klev) - integer kctop(klon),kcbot(klon) - - real qfx(klon),hfx(klon) - real zph(klon) - integer lndj(klon) - logical loflag(klon), deepflag(klon), resetflag(klon) - -! output variables - real cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) - integer culab(klon,klev) - real wbase(klon) - integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) - logical ldcum(klon) - -! local variables - real zqold(klon) - real rho, part1, part2, root, conw, deltt, deltq - real eta(klon),dz(klon),coef(klon) - real dhen(klon,klev), dh(klon,klev) - real plude(klon,klev) - real kup(klon,klev) - real vptu(klon,klev),vten(klon,klev) - real zbuo(klon,klev),abuoy(klon,klev) - - real zz,zdken,zdq - real fscale,crirh1,pp - real atop1,atop2,abot - real tmix,zmix,qmix,pmix - real zlglac,dp,t13 - integer nk,is,ikb,ikt - - real zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp - real zpdifftop, zpdiffbot - integer zcbase(klon), itoppacel(klon) - integer jl,jk,ik,icall,levels - logical needreset, lldcum(klon) -!-------------------------------------------------------------- - t13 = 1.0/3.0 -! - do jl=1,klon - kcbot(jl)=klev - kctop(jl)=klev - kdpl(jl) =klev - ktype(jl)=0 - wbase(jl)=0. - ldcum(jl)=.false. - end do - -!----------------------------------------------------------- -! let's do test,and check the shallow convection first -! the first level is klev -! define deltat and deltaq -!----------------------------------------------------------- - do jk=1,klev - do jl=1,klon - plu(jl,jk)=culu(jl,jk) ! parcel liquid water - ptu(jl,jk)=cutu(jl,jk) ! parcel temperature - pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity - klab(jl,jk)=culab(jl,jk) - dh(jl,jk)=0.0 ! parcel dry static energy - dhen(jl,jk)=0.0 ! environment dry static energy - kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading - vten(jl,jk)=0.0 ! environment virtual temperature - zbuo(jl,jk)=0.0 ! parcel buoyancy - abuoy(jl,jk)=0.0 - end do - end do - - do jl=1,klon - zqold(jl) = 0. - lldcum(jl) = .false. - loflag(jl) = .true. - end do - -! check the levels from lowest level to second top level - do jk=klevm1,2,-1 - -! define the variables at the first level - if(jk .eq. klevm1) then - do jl=1,klon - rho=pap(jl,klev)/ & - & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) - part1 = 1.5*0.4*pgeo(jl,klev)/ & - & (rho*pten(jl,klev)) - part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) - root = 0.001-part1*part2 - if(part2 .lt. 0.) then - conw = 1.2*(root)**t13 - deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) - deltq = max(1.5*qfx(jl)/(rho*conw),0.) - kup(jl,klev) = 0.5*(conw**2) - pqu(jl,klev)= pqenh(jl,klev) + deltq - dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd - dh(jl,klev) = dhen(jl,klev) + deltt*cpd - ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd - vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) - vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) - zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) - klab(jl,klev) = 1 - else - loflag(jl) = .false. - end if - end do - end if - - is=0 - do jl=1,klon - if(loflag(jl))then - is=is+1 - endif - enddo - if(is.eq.0) exit - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(loflag(jl)) then - eta(jl) = 0.8/(pgeo(jl,jk)*zrg)+2.e-4 - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= 0.5*eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& - & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) - pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& - & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) - ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd - zqold(jl) = pqu(jl,jk) - zph(jl)=paph(jl,jk) - end if - end do -! check if the parcel is saturated - ik=jk - icall=1 - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - do jl=1,klon - if( loflag(jl) ) then - zdq = max((zqold(jl) - pqu(jl,jk)),0.) - plu(jl,jk) = plu(jl,jk+1) + zdq - zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & - (1.-foealfa(ptu(jl,jk+1)))) - plu(jl,jk) = min(plu(jl,jk),5.e-3) - dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) -! compute the updraft speed - vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& - ralfdcp*zlglac - vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) - abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g - atop1 = 1.0 - 2.*coef(jl) - atop2 = 2.0*dz(jl)*abuoy(jl,jk) - abot = 1.0 + 2.*coef(jl) - kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot - -! let's find the exact cloud base - if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then - ik = jk + 1 - zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) - zqsu = min(0.5,zqsu) - zcor = 1./(1.-vtmpc1*zqsu) - zqsu = zqsu*zcor - zdq = min(0.,pqu(jl,ik)-zqsu) - zalfaw = foealfa(ptu(jl,ik)) - zfacw = c5les/((ptu(jl,ik)-c4les)**2) - zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) - zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci - zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) - zcor = 1./(1.-vtmpc1*zesdp) - zdqsdt = zfac*zcor*zqsu - zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) - zdp = zdq/(zdqsdt*zdtdp) - zcbase(jl) = paph(jl,ik) + zdp -! chose nearest half level as cloud base (jk or jk+1) - zpdifftop = zcbase(jl) - paph(jl,jk) - zpdiffbot = paph(jl,jk+1) - zcbase(jl) - if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then - ikb = min(klev-1,jk+1) - klab(jl,ikb) = 2 - klab(jl,jk) = 2 - kcbot(jl) = ikb - plu(jl,jk+1) = 1.0e-8 - else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then - klab(jl,jk) = 2 - kcbot(jl) = jk - end if - end if - - if(kup(jl,jk) .lt. 0.)then - loflag(jl) = .false. - if(plu(jl,jk+1) .gt. 0.) then - kctop(jl) = jk - lldcum(jl) = .true. - else - lldcum(jl) = .false. - end if - else if(plu(jl,jk) .gt. 0.)then - klab(jl,jk)=2 - else - klab(jl,jk)=1 - end if - end if - end do - - end do ! end all the levels - - do jl=1,klon - ikb = kcbot(jl) - ikt = kctop(jl) - if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. - if(lldcum(jl)) then - ktype(jl) = 2 - ldcum(jl) = .true. - wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) - cubot(jl) = ikb - cutop(jl) = ikt - kdpl(jl) = klev - else - cutop(jl) = -1 - cubot(jl) = -1 - kdpl(jl) = klev - 1 - ldcum(jl) = .false. - wbase(jl) = 0. - end if - end do - - do jk=klev,1,-1 - do jl=1,klon - ikt = kctop(jl) - if(jk .ge. ikt)then - culab(jl,jk) = klab(jl,jk) - cutu(jl,jk) = ptu(jl,jk) - cuqu(jl,jk) = pqu(jl,jk) - culu(jl,jk) = plu(jl,jk) - end if - end do - end do - -!----------------------------------------------------------- -! next, let's check the deep convection -! the first level is klevm1-1 -! define deltat and deltaq -!---------------------------------------------------------- -! we check the parcel starting level by level -! assume the mix-layer is 60hPa - deltt = 0.2 - deltq = 1.0e-4 - do jl=1,klon - deepflag(jl) = .false. - end do - - do jk=klev,1,-1 - do jl=1,klon - if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk - end do - end do - - do levels=klevm1-1,klev/2,-1 ! loop starts - do jk=1,klev - do jl=1,klon - plu(jl,jk)=0.0 ! parcel liquid water - ptu(jl,jk)=0.0 ! parcel temperature - pqu(jl,jk)=0.0 ! parcel specific humidity - dh(jl,jk)=0.0 ! parcel dry static energy - dhen(jl,jk)=0.0 ! environment dry static energy - kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading - vten(jl,jk)=0.0 ! environment virtual temperature - abuoy(jl,jk)=0.0 - zbuo(jl,jk)=0.0 - klab(jl,jk)=0 - end do - end do - - do jl=1,klon - kcbot(jl) = levels - kctop(jl) = levels - zqold(jl) = 0. - lldcum(jl) = .false. - resetflag(jl)= .false. - loflag(jl) = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl)) - end do - -! start the inner loop to search the deep convection points - do jk=levels,2,-1 - is=0 - do jl=1,klon - if(loflag(jl))then - is=is+1 - endif - enddo - if(is.eq.0) exit - -! define the variables at the departure level - if(jk .eq. levels) then - do jl=1,klon - if(loflag(jl)) then - if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then - tmix=0. - qmix=0. - zmix=0. - pmix=0. - do nk=jk+2,jk,-1 - if(pmix < 50.e2) then - dp = paph(jl,nk) - paph(jl,nk-1) - tmix=tmix+dp*ptenh(jl,nk) - qmix=qmix+dp*pqenh(jl,nk) - zmix=zmix+dp*pgeoh(jl,nk) - pmix=pmix+dp - end if - end do - tmix=tmix/pmix - qmix=qmix/pmix - zmix=zmix/pmix - else - tmix=ptenh(jl,jk+1) - qmix=pqenh(jl,jk+1) - zmix=pgeoh(jl,jk+1) - end if - - pqu(jl,jk+1) = qmix + deltq - dhen(jl,jk+1)= zmix + tmix*cpd - dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd - ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd - kup(jl,jk+1) = 0.5 - klab(jl,jk+1)= 1 - vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) - vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) - zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) - end if - end do - end if - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(loflag(jl)) then -! define the fscale - fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) - eta(jl) = 1.75e-3*fscale - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= 0.5*eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& - & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) - pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& - & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) - ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd - zqold(jl) = pqu(jl,jk) - zph(jl)=paph(jl,jk) - end if - end do -! check if the parcel is saturated - ik=jk - icall=1 - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - - do jl=1,klon - if( loflag(jl) ) then - zdq = max((zqold(jl) - pqu(jl,jk)),0.) - plu(jl,jk) = plu(jl,jk+1) + zdq - zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & - (1.-foealfa(ptu(jl,jk+1)))) - plu(jl,jk) = 0.5*plu(jl,jk) - dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) -! compute the updraft speed - vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& - ralfdcp*zlglac - vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) - abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g - atop1 = 1.0 - 2.*coef(jl) - atop2 = 2.0*dz(jl)*abuoy(jl,jk) - abot = 1.0 + 2.*coef(jl) - kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot -! let's find the exact cloud base - if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then - ik = jk + 1 - zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) - zqsu = min(0.5,zqsu) - zcor = 1./(1.-vtmpc1*zqsu) - zqsu = zqsu*zcor - zdq = min(0.,pqu(jl,ik)-zqsu) - zalfaw = foealfa(ptu(jl,ik)) - zfacw = c5les/((ptu(jl,ik)-c4les)**2) - zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) - zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci - zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) - zcor = 1./(1.-vtmpc1*zesdp) - zdqsdt = zfac*zcor*zqsu - zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) - zdp = zdq/(zdqsdt*zdtdp) - zcbase(jl) = paph(jl,ik) + zdp -! chose nearest half level as cloud base (jk or jk+1) - zpdifftop = zcbase(jl) - paph(jl,jk) - zpdiffbot = paph(jl,jk+1) - zcbase(jl) - if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then - ikb = min(klev-1,jk+1) - klab(jl,ikb) = 2 - klab(jl,jk) = 2 - kcbot(jl) = ikb - plu(jl,jk+1) = 1.0e-8 - else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then - klab(jl,jk) = 2 - kcbot(jl) = jk - end if - end if - - if(kup(jl,jk) .lt. 0.)then - loflag(jl) = .false. - if(plu(jl,jk+1) .gt. 0.) then - kctop(jl) = jk - lldcum(jl) = .true. - else - lldcum(jl) = .false. - end if - else if(plu(jl,jk) .gt. 0.)then - klab(jl,jk)=2 - else - klab(jl,jk)=1 - end if - end if - end do - - end do ! end all the levels - - needreset = .false. - do jl=1,klon - ikb = kcbot(jl) - ikt = kctop(jl) - if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. - if(lldcum(jl)) then - ktype(jl) = 1 - ldcum(jl) = .true. - deepflag(jl) = .true. - wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) - cubot(jl) = ikb - cutop(jl) = ikt - kdpl(jl) = levels+1 - needreset = .true. - resetflag(jl)= .true. - end if - end do - - if(needreset) then - do jk=klev,1,-1 - do jl=1,klon - if(resetflag(jl)) then - ikt = kctop(jl) - ikb = kdpl(jl) - if(jk .le. ikb .and. jk .ge. ikt )then - culab(jl,jk) = klab(jl,jk) - cutu(jl,jk) = ptu(jl,jk) - cuqu(jl,jk) = pqu(jl,jk) - culu(jl,jk) = plu(jl,jk) - else - culab(jl,jk) = 1 - cutu(jl,jk) = ptenh(jl,jk) - cuqu(jl,jk) = pqenh(jl,jk) - culu(jl,jk) = 0. - end if - if ( jk .lt. ikt ) culab(jl,jk) = 0 - end if - end do - end do - end if - - end do ! end all cycles - - return - end subroutine cutypen - -!----------------------------------------------------------------- -! level 3 subroutines 'cuascn' -!----------------------------------------------------------------- - subroutine cuascn & - & (klon, klev, klevp1, klevm1, ptenh,& - & pqenh, puen, pven, pten, pqen,& - & pqsen, pgeo, pgeoh, pap, paph,& - & pqte, pverv, klwmin, ldcum, phcbase,& - & ktype, klab, ptu, pqu, plu,& - & puu, pvu, pmfu, pmfub, & - & pmfus, pmfuq, pmful, plude, pdmfup,& - & kcbot, kctop, kctop0, kcum, ztmst,& - & pqsenh, plglac, lndj, wup, wbase, kdpl, pmfude_rate) - implicit none -! this routine does the calculations for cloud ascents -! for cumulus parameterization -! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 -! y.wang iprc 11/01 modif. -! c.zhang iprc 05/12 modif. -!***purpose. -! -------- -! to produce cloud ascents for cu-parametrization -! (vertical profiles of t,q,l,u and v and corresponding -! fluxes as well as precipitation rates) -!***interface -! --------- -! this routine is called from *cumastr*. -!***method. -! -------- -! lift surface air dry-adiabatically to cloud base -! and then calculate moist ascent for -! entraining/detraining plume. -! entrainment and detrainment rates differ for -! shallow and deep cumulus convection. -! in case there is no penetrative or shallow convection -! check for possibility of mid level convection -! (cloud base values calculated in *cubasmc*) -!***externals -! --------- -! *cuadjtqn* adjust t and q due to condensation in ascent -! *cuentrn* calculate entrainment/detrainment rates -! *cubasmcn* calculate cloud base values for midlevel convection -!***reference -! --------- -! (tiedtke,1989) -!***input variables: -! ptenh [ztenh] - environ temperature on half levels. (cuini) -! pqenh [zqenh] - env. specific humidity on half levels. (cuini) -! puen - environment wind u-component. (mssflx) -! pven - environment wind v-component. (mssflx) -! pten - environment temperature. (mssflx) -! pqen - environment specific humidity. (mssflx) -! pqsen - environment saturation specific humidity. (mssflx) -! pgeo - geopotential. (mssflx) -! pgeoh [zgeoh] - geopotential on half levels, (mssflx) -! pap - pressure in pa. (mssflx) -! paph - pressure of half levels. (mssflx) -! pqte - moisture convergence (delta q/delta t). (mssflx) -! pverv - large scale vertical velocity (omega). (mssflx) -! klwmin [ilwmin] - level of minimum omega. (cuini) -! klab [ilab] - level label - 1: sub-cloud layer. -! 2: condensation level (cloud base) -! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) -!***variables modified by cuasc: -! ldcum - logical denoting profiles. (cubase) -! ktype - convection type - 1: penetrative (cumastr) -! 2: stratocumulus (cumastr) -! 3: mid-level (cuasc) -! ptu - cloud temperature. -! pqu - cloud specific humidity. -! plu - cloud liquid water (moisture condensed out) -! puu [zuu] - cloud momentum u-component. -! pvu [zvu] - cloud momentum v-component. -! pmfu - updraft mass flux. -! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) -! pmfuq [zmfuq] - updraft flux of specific humidity. -! pmful [zmful] - updraft flux of cloud liquid water. -! plude - liquid water returned to environment by detrainment. -! pdmfup [zmfup] - -! kcbot - cloud base level. (cubase) -! kctop - cloud top level -! kctop0 [ictop0] - estimate of cloud top. (cumastr) -! kcum [icum] - flag to control the call - - integer klev,klon,klevp1,klevm1 - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev),& - & pten(klon,klev), pqen(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klevp1),& - & pap(klon,klev), paph(klon,klevp1),& - & pqsen(klon,klev), pqte(klon,klev),& - & pverv(klon,klev), pqsenh(klon,klev) - real ptu(klon,klev), pqu(klon,klev),& - & puu(klon,klev), pvu(klon,klev),& - & pmfu(klon,klev), zph(klon),& - & pmfub(klon), & - & pmfus(klon,klev), pmfuq(klon,klev),& - & plu(klon,klev), plude(klon,klev),& - & pmful(klon,klev), pdmfup(klon,klev) - real zdmfen(klon), zdmfde(klon),& - & zmfuu(klon), zmfuv(klon),& - & zpbase(klon), zqold(klon) - real phcbase(klon), zluold(klon) - real zprecip(klon), zlrain(klon,klev) - real zbuo(klon,klev), kup(klon,klev) - real wup(klon) - real wbase(klon), zodetr(klon,klev) - real plglac(klon,klev) - - real eta(klon),dz(klon) - - integer klwmin(klon), ktype(klon),& - & klab(klon,klev), kcbot(klon),& - & kctop(klon), kctop0(klon) - integer lndj(klon) - logical ldcum(klon), loflag(klon) - logical llo2,llo3, llo1(klon) - - integer kdpl(klon) - real zoentr(klon), zdpmean(klon) - real pdmfen(klon,klev), pmfude_rate(klon,klev) -! local variables - integer jl,jk - integer ikb,icum,itopm2,ik,icall,is,kcum,jlm,jll - integer jlx(klon) - real ztmst,zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 - real zmftest,zmfmax,zqeen,zseen,zscde,zqude - real zmfusk,zmfuqk,zmfulk - real zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco - real zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold - real zrnew,zz,zdmfeu,zdmfdu,dp - real zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd - real atop1,atop2,abot -!-------------------------------- -!* 1. specify parameters -!-------------------------------- - zcons2=3./(g*ztmst) - zfacbuo = 0.5/(1.+0.5) - zprcdgw = cprcon*zrg - z_cldmax = 5.e-3 - z_cwifrac = 0.5 - z_cprc2 = 0.5 - z_cwdrag = (3.0/8.0)*0.506/0.2 -!--------------------------------- -! 2. set default values -!--------------------------------- - llo3 = .false. - do jl=1,klon - zluold(jl)=0. - wup(jl)=0. - zdpmean(jl)=0. - zoentr(jl)=0. - if(.not.ldcum(jl)) then - ktype(jl)=0 - kcbot(jl) = -1 - pmfub(jl) = 0. - pqu(jl,klev) = 0. - end if - end do - - ! initialize variout quantities - do jk=1,klev - do jl=1,klon - if(jk.ne.kcbot(jl)) plu(jl,jk)=0. - pmfu(jl,jk)=0. - pmfus(jl,jk)=0. - pmfuq(jl,jk)=0. - pmful(jl,jk)=0. - plude(jl,jk)=0. - plglac(jl,jk)=0. - pdmfup(jl,jk)=0. - zlrain(jl,jk)=0. - zbuo(jl,jk)=0. - kup(jl,jk)=0. - pdmfen(jl,jk) = 0. - pmfude_rate(jl,jk) = 0. - if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 - if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk - end do - end do - - do jl = 1,klon - if ( ktype(jl) == 3 ) ldcum(jl) = .false. - end do -!------------------------------------------------ -! 3.0 initialize values at cloud base level -!------------------------------------------------ - do jl=1,klon - kctop(jl)=kcbot(jl) - if(ldcum(jl)) then - ikb = kcbot(jl) - kup(jl,ikb) = 0.5*wbase(jl)**2 - pmfu(jl,ikb) = pmfub(jl) - pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) - pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) - pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) - end if - end do -! -!----------------------------------------------------------------- -! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) -! by doing first dry-adiabatic ascent and then -! by adjusting t,q and l accordingly in *cuadjtqn*, -! then check for buoyancy and set flags accordingly -!----------------------------------------------------------------- -! - do jk=klevm1,3,-1 -! specify cloud base values for midlevel convection -! in *cubasmc* in case there is not already convection -! --------------------------------------------------------------------- - ik=jk - call cubasmcn& - & (klon, klev, klevm1, ik, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, pgeoh, ldcum, ktype, klab, zlrain,& - & pmfu, pmfub, kcbot, ptu,& - & pqu, plu, puu, pvu, pmfus,& - & pmfuq, pmful, pdmfup) - is = 0 - jlm = 0 - do jl = 1,klon - loflag(jl) = .false. - zprecip(jl) = 0. - llo1(jl) = .false. - is = is + klab(jl,jk+1) - if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 - if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & - (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then - loflag(jl) = .true. - jlm = jlm + 1 - jlx(jlm) = jl - end if - zph(jl) = paph(jl,jk) - if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - if ( pmfub(jl) > zmfmax ) then - zfac = zmfmax/pmfub(jl) - pmfu(jl,jk+1) = pmfu(jl,jk+1)*zfac - pmfus(jl,jk+1) = pmfus(jl,jk+1)*zfac - pmfuq(jl,jk+1) = pmfuq(jl,jk+1)*zfac - pmfub(jl) = zmfmax - end if - pmfub(jl)=min(pmfub(jl),zmfmax) - end if - end do - - if(is.gt.0) llo3 = .true. -! -!* specify entrainment rates in *cuentr* -! ------------------------------------- - ik=jk - call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & - pgeoh,pmfu,zdmfen,zdmfde) -! -! do adiabatic ascent for entraining/detraining plume - if(llo3) then -! ------------------------------------------------------- -! - do jl = 1,klon - zqold(jl) = 0. - end do - do jll = 1 , jlm - jl = jlx(jll) - zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) - if ( jk == kcbot(jl) ) then - zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & - 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) - end if - if ( jk < kcbot(jl) ) then - zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 - zxs = max(pmfu(jl,jk+1)-zmfmax,0.) - wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) - zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) - zdmfen(jl) = zoentr(jl) - if ( ktype(jl) >= 2 ) then - zdmfen(jl) = 2.0*zdmfen(jl) - zdmfde(jl) = zdmfen(jl) - end if - zdmfde(jl) = zdmfde(jl) * & - (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) - zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - zchange = max(zmftest-zmfmax,0.) - zxe = max(zchange-zxs,0.) - zdmfen(jl) = zdmfen(jl) - zxe - zchange = zchange - zxe - zdmfde(jl) = zdmfde(jl) + zchange - end if - pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) - pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - zqeen = pqenh(jl,jk+1)*zdmfen(jl) - zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) - zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) - zqude = pqu(jl,jk+1)*zdmfde(jl) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - zmfusk = pmfus(jl,jk+1) + zseen - zscde - zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude - zmfulk = pmful(jl,jk+1) - plude(jl,jk) - plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) - pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) - ptu(jl,jk) = (zmfusk * & - (1./max(cmfcmin,pmfu(jl,jk)))-pgeoh(jl,jk))*rcpd - ptu(jl,jk) = max(100.,ptu(jl,jk)) - ptu(jl,jk) = min(400.,ptu(jl,jk)) - zqold(jl) = pqu(jl,jk) - zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & - (1./max(cmfcmin,pmfu(jl,jk))) - zluold(jl) = plu(jl,jk) - end do -! reset to environmental values if below departure level - do jl = 1,klon - if ( jk > kdpl(jl) ) then - ptu(jl,jk) = ptenh(jl,jk) - pqu(jl,jk) = pqenh(jl,jk) - plu(jl,jk) = 0. - zluold(jl) = plu(jl,jk) - end if - end do -!* do corrections for moist ascent -!* by adjusting t,q and l in *cuadjtq* -!------------------------------------------------ - ik=jk - icall=1 -! - if ( jlm > 0 ) then - call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) - end if -! compute the upfraft speed in cloud layer - do jll = 1 , jlm - jl = jlx(jll) - if ( pqu(jl,jk) /= zqold(jl) ) then - plglac(jl,jk) = plu(jl,jk) * & - ((1.-foealfa(ptu(jl,jk)))- & - (1.-foealfa(ptu(jl,jk+1)))) - ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) - end if - end do - do jll = 1 , jlm - jl = jlx(jll) - if ( pqu(jl,jk) /= zqold(jl) ) then - klab(jl,jk) = 2 - plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) - zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & - zlrain(jl,jk+1)) - zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - zbuo(jl,jk) = zbc - zbe -! set flags for the case of midlevel convection - if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then - if ( zbuo(jl,jk) > -0.5 ) then - ldcum(jl) = .true. - kctop(jl) = jk - kup(jl,jk) = 0.5 - else - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - plude(jl,jk) = 0. - plu(jl,jk) = 0. - end if - end if - if ( klab(jl,jk+1) == 2 ) then - if ( zbuo(jl,jk) < 0. ) then - ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) - pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) - zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) - end if - zbuoc = (zbuo(jl,jk) / & - (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & - (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 - zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc -! mixing and "pressure" gradient term in upper troposphere - if ( zdmfen(jl) > 0. ) then - zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & - max(cmfcmin,pmfu(jl,jk+1))) - else - zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & - max(cmfcmin,pmfu(jl,jk+1))) - end if - kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & - (1.+zdken) - if ( zbuo(jl,jk) < 0. ) then - zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) - zkedke = max(0.,min(1.,zkedke)) - zmfun = sqrt(zkedke)*pmfu(jl,jk+1) - zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) - end if - if ( zbuo(jl,jk) > 0. ) then - ikb = kcbot(jl) - zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & - pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & - zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 - zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) - else - zoentr(jl) = 0. - end if -! erase values if below departure level - if ( jk > kdpl(jl) ) then - pmfu(jl,jk) = pmfu(jl,jk+1) - kup(jl,jk) = 0.5 - end if - if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then - kctop(jl) = jk - llo1(jl) = .true. - else - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - kup(jl,jk) = 0. - zdmfde(jl) = pmfu(jl,jk+1) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - end if -! save detrainment rates for updraught - if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) - end if - else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then - klab(jl,jk) = 0 - pmfu(jl,jk) = 0. - kup(jl,jk) = 0. - zdmfde(jl) = pmfu(jl,jk+1) - plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) - pmfude_rate(jl,jk) = zdmfde(jl) - end if - end do - - do jl = 1,klon - if ( llo1(jl) ) then -! conversions only proceeds if plu is greater than a threshold liquid water -! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation -! generation from small water contents. - if ( lndj(jl).eq.1 ) then - zdshrd = 5.e-4 - else - zdshrd = 3.e-4 - end if - ikb=kcbot(jl) -! if((paph(jl,ikb)-paph(jl,jk))>zdnoprc) then - if ( plu(jl,jk) > zdshrd )then - zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) - zprcon = zprcdgw/(0.75*zwu) -! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) - zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) - zcbf = 1. + z_cprc2*sqrt(zdt) - zzco = zprcon*zcbf - zlcrit = zdshrd/zcbf - zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) - zc = (plu(jl,jk)-zluold(jl)) - zarg = (plu(jl,jk)/zlcrit)**2 - if ( zarg < 25.0 ) then - zd = zzco*(1.-exp(-zarg))*zdfi - else - zd = zzco*zdfi - end if - zint = exp(-zd) - zlnew = zluold(jl)*zint + zc/zd*(1.-zint) - zlnew = max(0.,min(plu(jl,jk),zlnew)) - zlnew = min(z_cldmax,zlnew) - zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) - pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) - zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) - plu(jl,jk) = zlnew - end if - end if - end do - do jl = 1, klon - if ( llo1(jl) ) then - if ( zlrain(jl,jk) > 0. ) then - zvw = 21.18*zlrain(jl,jk)**0.2 - zvi = z_cwifrac*zvw - zalfaw = foealfa(ptu(jl,jk)) - zvv = zalfaw*zvw + (1.-zalfaw)*zvi - zrold = zlrain(jl,jk) - zprecip(jl) - zc = zprecip(jl) - zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) - zd = zvv/zwu - zint = exp(-zd) - zrnew = zrold*zint + zc/zd*(1.-zint) - zrnew = max(0.,min(zlrain(jl,jk),zrnew)) - zlrain(jl,jk) = zrnew - end if - end if - end do - do jll = 1 , jlm - jl = jlx(jll) - pmful(jl,jk) = plu(jl,jk)*pmfu(jl,jk) - pmfus(jl,jk) = (cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) - pmfuq(jl,jk) = pqu(jl,jk)*pmfu(jl,jk) - end do - end if - end do -!---------------------------------------------------------------------- -! 5. final calculations -! ------------------ - do jl = 1,klon - if ( kctop(jl) == -1 ) ldcum(jl) = .false. - kcbot(jl) = max(kcbot(jl),kctop(jl)) - if ( ldcum(jl) ) then - wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) - wup(jl) = sqrt(2.*wup(jl)) - end if - end do - - return - end subroutine cuascn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudlfsn & - & (klon, klev, & - & kcbot, kctop, lndj, ldcum, & - & ptenh, pqenh, puen, pven, & - & pten, pqsen, pgeo, & - & pgeoh, paph, ptu, pqu, plu,& - & puu, pvu, pmfub, prfl, & - & ptd, pqd, pud, pvd, & - & pmfd, pmfds, pmfdq, pdmfdp, & - & kdtop, lddraf) - -! this routine calculates level of free sinking for -! cumulus downdrafts and specifies t,q,u and v values - -! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 - -! purpose. -! -------- -! to produce lfs-values for cumulus downdrafts -! for massflux cumulus parameterization - -! interface -! --------- -! this routine is called from *cumastr*. -! input are environmental values of t,q,u,v,p,phi -! and updraft values t,q,u and v and also -! cloud base massflux and cu-precipitation rate. -! it returns t,q,u and v values and massflux at lfs. - -! method. - -! check for negative buoyancy of air of equal parts of -! moist environmental air and cloud air. - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level - -! input parameters (logical): - -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points - -! input parameters (real): - -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pten* provisional environment temperature (t+1) k -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *ptu* temperature in updrafts k -! *pqu* spec. humidity in updrafts kg/kg -! *plu* liquid water content in updrafts kg/kg -! *puu* u-velocity in updrafts m/s -! *pvu* v-velocity in updrafts m/s -! *pmfub* massflux in updrafts at cloud base kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) - -! output parameters (integer): - -! *kdtop* top level of downdrafts - -! output parameters (logical): - -! *lddraf* .true. if downdrafts exist - -! externals -! --------- -! *cuadjtq* for calculating wet bulb t and q at lfs -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pten(klon,klev), pqsen(klon,klev), & - & pgeo(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1),& - & ptu(klon,klev), pqu(klon,klev), & - & puu(klon,klev), pvu(klon,klev), & - & plu(klon,klev), & - & pmfub(klon), prfl(klon) - - real ptd(klon,klev), pqd(klon,klev), & - & pud(klon,klev), pvd(klon,klev), & - & pmfd(klon,klev), pmfds(klon,klev), & - & pmfdq(klon,klev), pdmfdp(klon,klev) - integer kcbot(klon), kctop(klon), & - & kdtop(klon), ikhsmin(klon) - logical ldcum(klon), & - & lddraf(klon) - integer lndj(klon) - - real ztenwb(klon,klev), zqenwb(klon,klev), & - & zcond(klon), zph(klon), & - & zhsmin(klon) - logical llo2(klon) -! local variables - integer jl,jk - integer is,ik,icall,ike - real zhsk,zttest,zqtest,zbuo,zmftop - -!---------------------------------------------------------------------- - -! 1. set default values for downdrafts -! --------------------------------- - do jl=1,klon - lddraf(jl)=.false. - kdtop(jl)=klev+1 - ikhsmin(jl)=klev+1 - zhsmin(jl)=1.e8 - enddo -!---------------------------------------------------------------------- - -! 2. determine level of free sinking: -! downdrafts shall start at model level of minimum -! of saturation moist static energy or below -! respectively - -! for every point and proceed as follows: - -! (1) determine level of minimum of hs -! (2) determine wet bulb environmental t and q -! (3) do mixing with cumulus cloud air -! (4) check for negative buoyancy -! (5) if buoyancy>0 repeat (2) to (4) for next -! level below - -! the assumption is that air of downdrafts is mixture -! of 50% cloud air + 50% environmental air at wet bulb -! temperature (i.e. which became saturated due to -! evaporation of rain and cloud water) -! ---------------------------------------------------- - do jk=3,klev-2 - do jl=1,klon - zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & - & foelhm(pten(jl,jk))*pqsen(jl,jk) - if(zhsk .lt. zhsmin(jl)) then - zhsmin(jl) = zhsk - ikhsmin(jl)= jk - end if - end do - end do - - - ike=klev-3 - do jk=3,ike - -! 2.1 calculate wet-bulb temperature and moisture -! for environmental air in *cuadjtq* -! ------------------------------------------- - is=0 - do jl=1,klon - ztenwb(jl,jk)=ptenh(jl,jk) - zqenwb(jl,jk)=pqenh(jl,jk) - zph(jl)=paph(jl,jk) - llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & - & (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)).and. jk.ge.ikhsmin(jl) - if(llo2(jl))then - is=is+1 - endif - enddo - if(is.eq.0) cycle - - ik=jk - icall=2 - call cuadjtqn & - & ( klon, klev, ik, zph, ztenwb, zqenwb, llo2, icall) - -! 2.2 do mixing of cumulus and environmental air -! and check for negative buoyancy. -! then set values for downdraft at lfs. -! ---------------------------------------- - do jl=1,klon - if(llo2(jl)) then - zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) - zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) - zbuo=zttest*(1.+vtmpc1 *zqtest)- & - & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) - zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) - zmftop=-cmfdeps*pmfub(jl) - if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then - kdtop(jl)=jk - lddraf(jl)=.true. - ptd(jl,jk)=zttest - pqd(jl,jk)=zqtest - pmfd(jl,jk)=zmftop - pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) - pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) - pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) - prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) - endif - endif - enddo - - enddo - - return - end subroutine cudlfsn - -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- -!********************************************** -! subroutine cuddrafn -!********************************************** - subroutine cuddrafn & - & ( klon, klev, lddraf & - & , ptenh, pqenh, puen, pven & - & , pgeo, pgeoh, paph, prfl & - & , ptd, pqd, pud, pvd, pmfu & - & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) - -! this routine calculates cumulus downdraft descent - -! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 - -! purpose. -! -------- -! to produce the vertical profiles for cumulus downdrafts -! (i.e. t,q,u and v and fluxes) - -! interface -! --------- - -! this routine is called from *cumastr*. -! input is t,q,p,phi,u,v at half levels. -! it returns fluxes of s,q and evaporation rate -! and u,v at levels where downdraft occurs - -! method. -! -------- -! calculate moist descent for entraining/detraining plume by -! a) moving air dry-adiabatically to next level below and -! b) correcting for evaporation to obtain saturated state. - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels - -! input parameters (logical): - -! *lddraf* .true. if downdrafts exist - -! input parameters (real): - -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *puen* provisional environment u-velocity (t+1) m/s -! *pven* provisional environment v-velocity (t+1) m/s -! *pgeo* geopotential m2/s2 -! *pgeoh* geopotential on half levels m2/s2 -! *paph* provisional pressure on half levels pa -! *pmfu* massflux updrafts kg/(m2*s) - -! updated parameters (real): - -! *prfl* precipitation rate kg/(m2*s) - -! output parameters (real): - -! *ptd* temperature in downdrafts k -! *pqd* spec. humidity in downdrafts kg/kg -! *pud* u-velocity in downdrafts m/s -! *pvd* v-velocity in downdrafts m/s -! *pmfd* massflux in downdrafts kg/(m2*s) -! *pmfds* flux of dry static energy in downdrafts j/(m2*s) -! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) -! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) - -! externals -! --------- -! *cuadjtq* for adjusting t and q due to evaporation in -! saturated descent -!---------------------------------------------------------------------- - implicit none - - integer klev,klon - real ptenh(klon,klev), pqenh(klon,klev), & - & puen(klon,klev), pven(klon,klev), & - & pgeoh(klon,klev+1), paph(klon,klev+1), & - & pgeo(klon,klev), pmfu(klon,klev) - - real ptd(klon,klev), pqd(klon,klev), & - & pud(klon,klev), pvd(klon,klev), & - & pmfd(klon,klev), pmfds(klon,klev), & - & pmfdq(klon,klev), pdmfdp(klon,klev), & - & prfl(klon) - real pmfdde_rate(klon,klev) - logical lddraf(klon) - - real zdmfen(klon), zdmfde(klon), & - & zcond(klon), zoentr(klon), & - & zbuoy(klon) - real zph(klon) - logical llo2(klon) - logical llo1 -! local variables - integer jl,jk - integer is,ik,icall,ike, itopde(klon) - real zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp - real zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk - -!---------------------------------------------------------------------- -! 1. calculate moist descent for cumulus downdraft by -! (a) calculating entrainment/detrainment rates, -! including organized entrainment dependent on -! negative buoyancy and assuming -! linear decrease of massflux in pbl -! (b) doing moist descent - evaporative cooling -! and moistening is calculated in *cuadjtq* -! (c) checking for negative buoyancy and -! specifying final t,q,u,v and downward fluxes -! ------------------------------------------------- - do jl=1,klon - zoentr(jl)=0. - zbuoy(jl)=0. - zdmfen(jl)=0. - zdmfde(jl)=0. - enddo - - do jk=klev,1,-1 - do jl=1,klon - pmfdde_rate(jl,jk) = 0. - if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk - end do - end do - - do jk=3,klev - is=0 - do jl=1,klon - zph(jl)=paph(jl,jk) - llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. - if(llo2(jl)) then - is=is+1 - endif - enddo - if(is.eq.0) cycle - - do jl=1,klon - if(llo2(jl)) then - zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zdmfen(jl)=zentr - zdmfde(jl)=zentr - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - if(jk.gt.itopde(jl)) then - zdmfen(jl)=0. - zdmfde(jl)=pmfd(jl,itopde(jl))* & - & (paph(jl,jk)-paph(jl,jk-1))/ & - & (paph(jl,klev+1)-paph(jl,itopde(jl))) - endif - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - if(jk.le.itopde(jl)) then - zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) - zdmfen(jl)=zdmfen(jl)+zzentr - zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) - zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & - & (pmfd(jl,jk-1)-zdmfde(jl))) - zdmfen(jl)=min(zdmfen(jl),0.) - endif - endif - enddo - - do jl=1,klon - if(llo2(jl)) then - pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) - zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) - zqeen=pqenh(jl,jk-1)*zdmfen(jl) - zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) - zqdde=pqd(jl,jk-1)*zdmfde(jl) - zmfdsk=pmfds(jl,jk-1)+zseen-zsdde - zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde - pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) - ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& - & pgeoh(jl,jk))*rcpd - ptd(jl,jk)=min(400.,ptd(jl,jk)) - ptd(jl,jk)=max(100.,ptd(jl,jk)) - zcond(jl)=pqd(jl,jk) - endif - enddo - - ik=jk - icall=2 - call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) - - do jl=1,klon - if(llo2(jl)) then - zcond(jl)=zcond(jl)-pqd(jl,jk) - zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & - & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) - if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then - zrain=prfl(jl)/pmfu(jl,jk) - zbuo=zbuo-ptd(jl,jk)*zrain - endif - if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then - pmfd(jl,jk)=0. - zbuo=0. - endif - pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) - pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) - zdmfdp=-pmfd(jl,jk)*zcond(jl) - pdmfdp(jl,jk-1)=zdmfdp - prfl(jl)=prfl(jl)+zdmfdp - -! compute organized entrainment for use at next level - zbuoyz=zbuo/ptenh(jl,jk) - zbuoyz=min(zbuoyz,0.0) - zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) - zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz - zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) - pmfdde_rate(jl,jk) = -zdmfde(jl) - endif - enddo - - enddo - - return - end subroutine cuddrafn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cuflxn & - & ( klon, klev, ztmst & - & , pten, pqen, pqsen, ptenh, pqenh & - & , paph, pap, pgeoh, lndj, ldcum & - & , kcbot, kctop, kdtop, ktopm2 & - & , ktype, lddraf & - & , pmfu, pmfd, pmfus, pmfds & - & , pmfuq, pmfdq, pmful, plude & - & , pdmfup, pdmfdp, pdpmel, plglac & - & , prain, pmfdde_rate, pmflxr, pmflxs ) - -! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 - -! purpose -! ------- - -! this routine does the final calculation of convective -! fluxes in the cloud layer and in the subcloud layer - -! interface -! --------- -! this routine is called from *cumastr*. - - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kcbot* cloud base level -! *kctop* cloud top level -! *kdtop* top level of downdrafts - -! input parameters (logical): - -! *lndj* land sea mask (1 for land) -! *ldcum* flag: .true. for convective points - -! input parameters (real): - -! *ptsphy* time step for the physics s -! *pten* provisional environment temperature (t+1) k -! *pqen* provisional environment spec. humidity (t+1) kg/kg -! *pqsen* environment spec. saturation humidity (t+1) kg/kg -! *ptenh* env. temperature (t+1) on half levels k -! *pqenh* env. spec. humidity (t+1) on half levels kg/kg -! *paph* provisional pressure on half levels pa -! *pap* provisional pressure on full levels pa -! *pgeoh* geopotential on half levels m2/s2 - -! updated parameters (integer): - -! *ktype* set to zero if ldcum=.false. - -! updated parameters (logical): - -! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) - if ( llddraf .and.jk.ge.kdtop(jl)) then - pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & - (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) - pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) - else - pmfd(jl,jk) = 0. - pmfds(jl,jk) = 0. - pmfdq(jl,jk) = 0. - pdmfdp(jl,jk-1) = 0. - end if - if ( llddraf .and. pmfd(jl,jk) < 0. .and. & - abs(pmfd(jl,ikb)) < 1.e-20 ) then - idbas(jl) = jk - end if - else - pmfu(jl,jk)=0. - pmfd(jl,jk)=0. - pmfus(jl,jk)=0. - pmfds(jl,jk)=0. - pmfuq(jl,jk)=0. - pmfdq(jl,jk)=0. - pmful(jl,jk)=0. - plglac(jl,jk)=0. - pdmfup(jl,jk-1)=0. - pdmfdp(jl,jk-1)=0. - plude(jl,jk-1)=0. - endif - enddo - enddo - - do jl=1,klon - pmflxr(jl,klev+1) = 0. - pmflxs(jl,klev+1) = 0. - end do - do jl=1,klon - if(ldcum(jl)) then - ikb=kcbot(jl) - ik=ikb+1 - zzp=((paph(jl,klev+1)-paph(jl,ik))/ & - & (paph(jl,klev+1)-paph(jl,ikb))) - if(ktype(jl).eq.3) then - zzp=zzp**2 - endif - pmfu(jl,ik)=pmfu(jl,ikb)*zzp - pmfus(jl,ik)=(pmfus(jl,ikb)- & - & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp - pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp - pmful(jl,ik)=0. - endif - enddo - - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then - ikb=kcbot(jl)+1 - zzp=((paph(jl,klev+1)-paph(jl,jk))/ & - & (paph(jl,klev+1)-paph(jl,ikb))) - if(ktype(jl).eq.3) then - zzp=zzp**2 - endif - pmfu(jl,jk)=pmfu(jl,ikb)*zzp - pmfus(jl,jk)=pmfus(jl,ikb)*zzp - pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp - pmful(jl,jk)=0. - endif - ik = idbas(jl) - llddraf = lddraf(jl) .and. jk > ik .and. ik < klev - if ( llddraf .and. ik == kcbot(jl)+1 ) then - zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) - if ( ktype(jl) == 3 ) zzp = zzp*zzp - pmfd(jl,jk) = pmfd(jl,ik)*zzp - pmfds(jl,jk) = pmfds(jl,ik)*zzp - pmfdq(jl,jk) = pmfdq(jl,ik)*zzp - pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) - else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then - pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) - end if - enddo - enddo -!* 2. calculate rain/snow fall rates -!* calculate melting of snow -!* calculate evaporation of precip -! ------------------------------- - - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then - prain(jl)=prain(jl)+pdmfup(jl,jk) - if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then - zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) - zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) - zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) - pdpmel(jl,jk)=zsnmlt - pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) - endif - zalfaw=foealfa(pten(jl,jk)) - ! - ! No liquid precipitation above melting level - ! - if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then - plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) - zalfaw = 0. - end if - pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & - & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) - pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & - & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) - if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then - pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) - pmflxr(jl,jk+1)=0.0 - pmflxs(jl,jk+1)=0.0 - pdpmel(jl,jk) =0.0 - else if ( pmflxr(jl,jk+1) < 0. ) then - pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) - pmflxr(jl,jk+1) = 0. - else if ( pmflxs(jl,jk+1) < 0. ) then - pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) - pmflxs(jl,jk+1) = 0. - end if - endif - enddo - enddo - do jk=ktopm2,klev - do jl=1,klon - if(ldcum(jl).and.jk.ge.kcbot(jl)) then - zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) - if(zrfl.gt.1.e-20) then - zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & - & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & - & zrfl/zcucov)**0.5777* & - & (paph(jl,jk+1)-paph(jl,jk)) - zrnew=zrfl-zdrfl1 - zrmin=zrfl-zcucov*max(0.,rhevap(jl)*pqsen(jl,jk) & - & -pqen(jl,jk)) *zcons2*(paph(jl,jk+1)-paph(jl,jk)) - zrnew=max(zrnew,zrmin) - zrfln=max(zrnew,0.) - zdrfl=min(0.,zrfln-zrfl) - zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) - zalfaw=foealfa(pten(jl,jk)) - if ( pten(jl,jk) < tmelt ) zalfaw = 0. - zpdr=zalfaw*pdmfdp(jl,jk) - zpds=(1.-zalfaw)*pdmfdp(jl,jk) - pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & - & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom - pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & - & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom - pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl - if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then - pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) - pmflxr(jl,jk+1) = 0. - pmflxs(jl,jk+1) = 0. - pdpmel(jl,jk) = 0. - else if ( pmflxr(jl,jk+1) < 0. ) then - pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) - pmflxr(jl,jk+1) = 0. - else if ( pmflxs(jl,jk+1) < 0. ) then - pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) - pmflxs(jl,jk+1) = 0. - end if - else - pmflxr(jl,jk+1)=0.0 - pmflxs(jl,jk+1)=0.0 - pdmfdp(jl,jk)=0.0 - pdpmel(jl,jk)=0.0 - endif - endif - enddo - enddo - - return - end subroutine cuflxn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & - lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & - pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & - pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) - implicit none - integer klon,klev,ktopm2 - integer kctop(klon), kdtop(klon) - logical ldcum(klon), lddraf(klon) - real ztmst - real paph(klon,klev+1), pgeoh(klon,klev+1) - real pgeo(klon,klev), pten(klon,klev), & - pqen(klon,klev), ptenh(klon,klev),& - pqenh(klon,klev), pqsen(klon,klev),& - plglac(klon,klev), plude(klon,klev) - real pmfu(klon,klev), pmfd(klon,klev),& - pmfus(klon,klev), pmfds(klon,klev),& - pmfuq(klon,klev), pmfdq(klon,klev),& - pmful(klon,klev), pdmfup(klon,klev),& - pdpmel(klon,klev), pdmfdp(klon,klev) - real ptent(klon,klev), ptenq(klon,klev) - real pcte(klon,klev) - -! local variables - integer jk , ik , jl - real zalv , zzp - real zmfus(klon,klev) , zmfuq(klon,klev) - real zmfds(klon,klev) , zmfdq(klon,klev) - real zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) - !* 1.0 SETUP AND INITIALIZATIONS - ! ------------------------- - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - zmfus(jl,jk) = pmfus(jl,jk) - zmfds(jl,jk) = pmfds(jl,jk) - zmfuq(jl,jk) = pmfuq(jl,jk) - zmfdq(jl,jk) = pmfdq(jl,jk) - end if - end do - end do - !----------------------------------------------------------------------- - !* 2.0 COMPUTE TENDENCIES - ! ------------------ - do jk = ktopm2 , klev - if ( jk < klev ) then - do jl = 1,klon - if ( ldcum(jl) ) then - zalv = foelhm(pten(jl,jk)) - zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & - (zmfus(jl,jk+1)-zmfus(jl,jk)+zmfds(jl,jk+1) - & - zmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) - zdqdt(jl,jk) = zdp(jl,jk)*(zmfuq(jl,jk+1) - & - zmfuq(jl,jk)+zmfdq(jl,jk+1)-zmfdq(jl,jk)+pmful(jl,jk+1) - & - pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) - end if - end do - else - do jl = 1,klon - if ( ldcum(jl) ) then - zalv = foelhm(pten(jl,jk)) - zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & - (zmfus(jl,jk)+zmfds(jl,jk)+alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) - zdqdt(jl,jk) = -zdp(jl,jk)*(zmfuq(jl,jk) + & - zmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) - end if - end do - end if - end do - !--------------------------------------------------------------- - !* 3.0 UPDATE TENDENCIES - ! ----------------- - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) - ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) - pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) - end if - end do - end do - - return - end subroutine cudtdqn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & - ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & - ptenv) - implicit none - integer klon,klev,ktopm2 - integer ktype(klon), kcbot(klon), kctop(klon) - logical ldcum(klon) - real ztmst - real paph(klon,klev+1) - real puen(klon,klev), pven(klon,klev),& - pmfu(klon,klev), pmfd(klon,klev),& - puu(klon,klev), pud(klon,klev),& - pvu(klon,klev), pvd(klon,klev) - real ptenu(klon,klev), ptenv(klon,klev) +!================================================================================================================= + subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & + rucuten,rvcuten,rthften,rqvften, & + restart,p_qc,p_qi,p_first_scalar, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) +!================================================================================================================= -!local variables - real zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & - zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) +!--- input arguments: + logical,intent(in):: allowed_to_read,restart - integer ik , ikb , jk , jl - real zzp, zdtdt - - real zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) -! - do jk = 1 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - zuen(jl,jk) = puen(jl,jk) - zven(jl,jk) = pven(jl,jk) - zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) - end if - end do - end do -!---------------------------------------------------------------------- -!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES -! ---------------------------------------------- - do jk = ktopm2 , klev - ik = jk - 1 - do jl = 1,klon - if ( ldcum(jl) ) then - zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) - zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) - zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) - zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) - end if - end do - end do - ! linear fluxes below cloud - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) .and. jk > kcbot(jl) ) then - ikb = kcbot(jl) - zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) - if ( ktype(jl) == 3 ) zzp = zzp*zzp - zmfuu(jl,jk) = zmfuu(jl,ikb)*zzp - zmfuv(jl,jk) = zmfuv(jl,ikb)*zzp - zmfdu(jl,jk) = zmfdu(jl,ikb)*zzp - zmfdv(jl,jk) = zmfdv(jl,ikb)*zzp - end if - end do - end do -!---------------------------------------------------------------------- -!* 2.0 COMPUTE TENDENCIES -! ------------------ - do jk = ktopm2 , klev - if ( jk < klev ) then - ik = jk + 1 - do jl = 1,klon - if ( ldcum(jl) ) then - zdudt(jl,jk) = zdp(jl,jk) * & - (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) - zdvdt(jl,jk) = zdp(jl,jk) * & - (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) - end if - end do - else - do jl = 1,klon - if ( ldcum(jl) ) then - zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) - zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) - end if - end do - end if - end do -!--------------------------------------------------------------------- -!* 3.0 UPDATE TENDENCIES -! ----------------- - do jk = ktopm2 , klev - do jl = 1, klon - if ( ldcum(jl) ) then - ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) - ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) - end if - end do - end do -!---------------------------------------------------------------------- - return - end subroutine cududvn -!--------------------------------------------------------- -! level 3 souroutines -!-------------------------------------------------------- - subroutine cuadjtqn & - & (klon, klev, kk, psp, pt, pq, ldflag, kcall) -! m.tiedtke e.c.m.w.f. 12/89 -! purpose. -! -------- -! to produce t,q and l values for cloud ascent - -! interface -! --------- -! this routine is called from subroutines: -! *cond* (t and q at condensation level) -! *cubase* (t and q at condensation level) -! *cuasc* (t and q at cloud levels) -! *cuini* (environmental t and qs values at half levels) -! input are unadjusted t and q values, -! it returns adjusted values of t and q - -! parameter description units -! --------- ----------- ----- -! input parameters (integer): - -! *klon* number of grid points per packet -! *klev* number of levels -! *kk* level -! *kcall* defines calculation as -! kcall=0 env. t and qs in*cuini* -! kcall=1 condensation in updrafts (e.g. cubase, cuasc) -! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf) -! input parameters (real): - -! *psp* pressure pa - -! updated parameters (real): - -! *pt* temperature k -! *pq* specific humidity kg/kg -! externals -! --------- -! for condensation calculations. -! the tables are initialised in *suphec*. - -!---------------------------------------------------------------------- - - implicit none - - integer klev,klon - real pt(klon,klev), pq(klon,klev), & - & psp(klon) - logical ldflag(klon) -! local variables - integer jl,jk - integer isum,kcall,kk - real zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf -!---------------------------------------------------------------------- -! 1. define constants -! ---------------- - zqmax=0.5 - -! 2. calculate condensation and adjust t and q accordingly -! ----------------------------------------------------- - - if ( kcall == 1 ) then - do jl = 1,klon - if ( ldflag(jl) ) then - zqp = 1./psp(jl) - zl = 1./(pt(jl,kk)-c4les) - zi = 1./(pt(jl,kk)-c4ies) - zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & - (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) - zqsat = zqsat*zqp - zqsat = min(0.5,zqsat) - zcor = 1. - vtmpc1*zqsat - zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & - (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 - zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) - if ( zcond > 0. ) then - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond - pq(jl,kk) = pq(jl,kk) - zcond - zl = 1./(pt(jl,kk)-c4les) - zi = 1./(pt(jl,kk)-c4ies) - zqsat = c2es*(foealfa(pt(jl,kk)) * & - exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & - exp(c3ies*(pt(jl,kk)-tmelt)*zi)) - zqsat = zqsat*zqp - zqsat = min(0.5,zqsat) - zcor = 1. - vtmpc1*zqsat - zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & - (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 - zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) - if ( abs(zcond) < 1.e-20 ) zcond1 = 0. - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end if - end if - end do - elseif ( kcall == 2 ) then - do jl = 1,klon - if ( ldflag(jl) ) then - zqp = 1./psp(jl) - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - zcond = min(zcond,0.) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond - pq(jl,kk) = pq(jl,kk) - zcond - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end if - end do - else if ( kcall == 0 ) then - do jl = 1,klon - zqp = 1./psp(jl) - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - zqsat = foeewm(pt(jl,kk))*zqp - zqsat = min(0.5,zqsat) - zcor = 1./(1.-vtmpc1*zqsat) - zqsat = zqsat*zcor - zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) - pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 - pq(jl,kk) = pq(jl,kk) - zcond1 - end do - end if + integer,intent(in):: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + integer,intent(in):: p_first_scalar,p_qi,p_qc - return - end subroutine cuadjtqn -!--------------------------------------------------------- -! level 4 souroutines -!-------------------------------------------------------- - subroutine cubasmcn & - & (klon, klev, klevm1, kk, pten,& - & pqen, pqsen, puen, pven, pverv,& - & pgeo, pgeoh, ldcum, ktype, klab, plrain,& - & pmfu, pmfub, kcbot, ptu,& - & pqu, plu, puu, pvu, pmfus,& - & pmfuq, pmful, pdmfup) - implicit none -! m.tiedtke e.c.m.w.f. 12/89 -! c.zhang iprc 05/2012 -!***purpose. -! -------- -! this routine calculates cloud base values -! for midlevel convection -!***interface -! --------- -! this routine is called from *cuasc*. -! input are environmental values t,q etc -! it returns cloudbase values for midlevel convection -!***method. -! ------- -! s. tiedtke (1989) -!***externals -! --------- -! none -! ---------------------------------------------------------------- - real pten(klon,klev), pqen(klon,klev),& - & puen(klon,klev), pven(klon,klev),& - & pqsen(klon,klev), pverv(klon,klev),& - & pgeo(klon,klev), pgeoh(klon,klev+1) - real ptu(klon,klev), pqu(klon,klev),& - & puu(klon,klev), pvu(klon,klev),& - & plu(klon,klev), pmfu(klon,klev),& - & pmfub(klon), & - & pmfus(klon,klev), pmfuq(klon,klev),& - & pmful(klon,klev), pdmfup(klon,klev),& - & plrain(klon,klev) - integer ktype(klon), kcbot(klon),& - & klab(klon,klev) - logical ldcum(klon) -! local variabels - integer jl,kk,klev,klon,klevp1,klevm1 - real zzzmb -!-------------------------------------------------------- -!* 1. calculate entrainment and detrainment rates -! ------------------------------------------------------- - do jl=1,klon - if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then - if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & - pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & - & pgeo(jl,kk)*zrg .lt. 1.0e4 ) then - ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1))& - & *rcpd - pqu(jl,kk+1)=pqen(jl,kk) - plu(jl,kk+1)=0. - zzzmb=max(cmfcmin,-pverv(jl,kk)*zrg) - zzzmb=min(zzzmb,cmfcmax) - pmfub(jl)=zzzmb - pmfu(jl,kk+1)=pmfub(jl) - pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) - pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) - pmful(jl,kk+1)=0. - pdmfup(jl,kk+1)=0. - kcbot(jl)=kk - klab(jl,kk+1)=1 - plrain(jl,kk+1)=0.0 - ktype(jl)=3 - end if - end if - end do - return - end subroutine cubasmcn -!--------------------------------------------------------- -! level 4 souroutines -!--------------------------------------------------------- - subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & - pgeoh,pmfu,pdmfen,pdmfde) - implicit none - integer klon,klev,kk - integer kcbot(klon) - logical ldcum(klon) - logical ldwork - real pgeoh(klon,klev+1) - real pmfu(klon,klev) - real pdmfen(klon) - real pdmfde(klon) - logical llo1 - integer jl - real zdz , zmf - real zentr(klon) - ! - !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES - ! ------------------------------------------- - if ( ldwork ) then - do jl = 1,klon - pdmfen(jl) = 0. - pdmfde(jl) = 0. - zentr(jl) = 0. - end do - ! - !* 1.1 SPECIFY ENTRAINMENT RATES - ! ------------------------- - do jl = 1, klon - if ( ldcum(jl) ) then - zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg - zmf = pmfu(jl,kk+1)*zdz - llo1 = kk < kcbot(jl) - if ( llo1 ) then - pdmfen(jl) = zentr(jl)*zmf - pdmfde(jl) = 0.75e-4*zmf - end if - end if - end do - end if - end subroutine cuentrn -!-------------------------------------------------------- -! external functions -!------------------------------------------------------ - real function foealfa(tt) -! foealfa is calculated to distinguish the three cases: -! -! foealfa=1 water phase -! foealfa=0 ice phase -! 0 < foealfa < 1 mixed phase -! -! input : tt = temperature -! - implicit none - real tt - foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & - & /(rtwat-rtice))**2) +!--- output arguments: + real(kind=kind_phys),intent(out),dimension(ims:ime,kms:kme,jms:jme ):: & + rthcuten,rqvcuten,rqccuten,rqicuten,rucuten,rvcuten,rthften,rqvften - return - end function foealfa +!--- local variables and arrays: + integer:: i,j,k,itf,jtf,ktf - real function foelhm(tt) - implicit none - real tt - foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als - return - end function foelhm +!----------------------------------------------------------------------------------------------------------------- - real function foeewm(tt) - implicit none - real tt - foeewm = c2es * & - & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & - & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) - return - end function foeewm + jtf = min0(jte,jde-1) + ktf = min0(kte,kde-1) + itf = min0(ite,ide-1) - real function foedem(tt) - implicit none - real tt - foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & - & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) - return - end function foedem + if(.not.restart)then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rthcuten(i,k,j) = 0. + rqvcuten(i,k,j) = 0. + rucuten(i,k,j) = 0. + rvcuten(i,k,j) = 0. + enddo + enddo + enddo + + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rthften(i,k,j)=0. + rqvften(i,k,j)=0. + enddo + enddo + enddo + + if(p_qc .ge. p_first_scalar) then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rqccuten(i,k,j)=0. + enddo + enddo + enddo + endif + + if(p_qi .ge. p_first_scalar) then + do j = jts,jtf + do k = kts,ktf + do i = its,itf + rqicuten(i,k,j)=0. + enddo + enddo + enddo + endif + endif - real function foeldcpm(tt) - implicit none - real tt - foeldcpm = foealfa(tt)*ralvdcp+ & - & (1.-foealfa(tt))*ralsdcp - return - end function foeldcpm + end subroutine ntiedtkeinit -end module module_cu_ntiedtke +!================================================================================================================= + end module module_cu_ntiedtke +!================================================================================================================= 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 a2b57f8377..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 ------------------------------ @@ -564,6 +561,7 @@ subroutine tiecnv(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & !----------------------------------------------------------------- implicit none + integer lq,km,km1 real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km) real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km) @@ -589,7 +587,7 @@ subroutine tiecnv(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & real psheat,psrain,psevap,psmelt,psdiss,tt real ztmst,ztpp1,fliq,fice,ztc,zalf - integer i,j,k,lq,lp,km,km1 + integer i,j,k,lp ! real tlucua ! external tlucua diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F b/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F index d68951187f..ebe64ee153 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_radar.F @@ -25,6 +25,7 @@ MODULE module_mp_radar #if defined(mpas) USE mpas_atmphys_functions USE mpas_atmphys_utilities + USE mpas_kind_types, ONLY : R8KIND #else USE module_wrf_error #endif @@ -44,12 +45,16 @@ MODULE module_mp_radar PRIVATE :: GAMMLN #endif +#if !defined(mpas) + INTEGER, PARAMETER :: R8KIND = SELECTED_REAL_KIND(12) +#endif + INTEGER, PARAMETER, PUBLIC:: nrbins = 50 DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: xxDx DOUBLE PRECISION, DIMENSION(nrbins), PUBLIC:: xxDs,xdts,xxDg,xdtg DOUBLE PRECISION, PARAMETER, PUBLIC:: lamda_radar = 0.10 ! in meters DOUBLE PRECISION, PUBLIC:: K_w, PI5, lamda4 - COMPLEX*16, PUBLIC:: m_w_0, m_i_0 + COMPLEX(KIND=R8KIND), PUBLIC:: m_w_0, m_i_0 DOUBLE PRECISION, DIMENSION(nrbins+1), PUBLIC:: simpson DOUBLE PRECISION, DIMENSION(3), PARAMETER, PUBLIC:: basis = & (/1.d0/3.d0, 4.d0/3.d0, 1.d0/3.d0/) @@ -130,7 +135,7 @@ subroutine radar_init xxDx(1) = 100.D-6 xxDx(nrbins+1) = 0.02d0 do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & + xxDx(n) = DEXP(REAL(n-1,KIND=R8KIND)/REAL(nrbins,KIND=R8KIND) & *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) enddo do n = 1, nrbins @@ -142,7 +147,7 @@ subroutine radar_init xxDx(1) = 100.D-6 xxDx(nrbins+1) = 0.05d0 do n = 2, nrbins - xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nrbins) & + xxDx(n) = DEXP(REAL(n-1,KIND=R8KIND)/REAL(nrbins,KIND=R8KIND) & *DLOG(xxDx(nrbins+1)/xxDx(1)) +DLOG(xxDx(1))) enddo do n = 1, nrbins @@ -197,7 +202,7 @@ end subroutine radar_init !+---+-----------------------------------------------------------------+ !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) + COMPLEX(KIND=R8KIND) FUNCTION m_complex_water_ray(lambda,T) ! Complex refractive Index of Water as function of Temperature T ! [deg C] and radar wavelength lambda [m]; valid for @@ -208,7 +213,7 @@ COMPLEX*16 FUNCTION m_complex_water_ray(lambda,T) DOUBLE PRECISION, INTENT(IN):: T,lambda DOUBLE PRECISION:: epsinf,epss,epsr,epsi DOUBLE PRECISION:: alpha,lambdas,sigma,nenner - COMPLEX*16, PARAMETER:: i = (0d0,1d0) + COMPLEX(KIND=R8KIND), PARAMETER:: i = (0d0,1d0) DOUBLE PRECISION, PARAMETER:: PIx=3.1415926535897932384626434d0 epsinf = 5.27137d0 + 0.02164740d0 * T - 0.00131198d0 * T*T @@ -232,7 +237,7 @@ END FUNCTION m_complex_water_ray !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION m_complex_ice_maetzler(lambda,T) + COMPLEX(KIND=R8KIND) FUNCTION m_complex_ice_maetzler(lambda,T) ! complex refractive index of ice as function of Temperature T ! [deg C] and radar wavelength lambda [m]; valid for @@ -281,11 +286,11 @@ subroutine rayleigh_soak_wetgraupel (x_g, a_geo, b_geo, fmelt, & DOUBLE PRECISION, INTENT(in):: x_g, a_geo, b_geo, fmelt, lambda, & meltratio_outside DOUBLE PRECISION, INTENT(out):: C_back - COMPLEX*16, INTENT(in):: m_w, m_i + COMPLEX(KIND=R8KIND), INTENT(in):: m_w, m_i CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion, & host, hostmatrix, hostinclusion - COMPLEX*16:: m_core, m_air + COMPLEX(KIND=R8KIND):: m_core, m_air DOUBLE PRECISION:: D_large, D_g, rhog, x_w, xw_a, fm, fmgrenz, & volg, vg, volair, volice, volwater, & meltratio_outside_grenz, mra @@ -368,20 +373,20 @@ end subroutine rayleigh_soak_wetgraupel !+---+-----------------------------------------------------------------+ - complex*16 function get_m_mix_nested (m_a, m_i, m_w, volair, & + complex(kind=R8KIND) function get_m_mix_nested (m_a, m_i, m_w, volair, & volice, volwater, mixingrule, host, matrix, & inclusion, hostmatrix, hostinclusion, cumulerror) IMPLICIT NONE DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w + COMPLEX(KIND=R8KIND), INTENT(in):: m_a, m_i, m_w CHARACTER(len=*), INTENT(in):: mixingrule, host, matrix, & inclusion, hostmatrix, hostinclusion INTEGER, INTENT(out):: cumulerror DOUBLE PRECISION:: vol1, vol2 - COMPLEX*16:: mtmp + COMPLEX(KIND=R8KIND):: mtmp INTEGER:: error !..Folded: ( (m1 + m2) + m3), where m1,m2,m3 could each be @@ -538,13 +543,13 @@ end function get_m_mix_nested !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & + COMPLEX(KIND=R8KIND) FUNCTION get_m_mix (m_a, m_i, m_w, volair, volice, & volwater, mixingrule, matrix, inclusion, error) IMPLICIT NONE DOUBLE PRECISION, INTENT(in):: volice, volair, volwater - COMPLEX*16, INTENT(in):: m_a, m_i, m_w + COMPLEX(KIND=R8KIND), INTENT(in):: m_a, m_i, m_w CHARACTER(len=*), INTENT(in):: mixingrule, matrix, inclusion INTEGER, INTENT(out):: error @@ -594,16 +599,16 @@ END FUNCTION get_m_mix !+---+-----------------------------------------------------------------+ - COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & + COMPLEX(KIND=R8KIND) FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & m1, m2, m3, inclusion, error) IMPLICIT NONE - COMPLEX*16 :: m1, m2, m3 + COMPLEX(KIND=R8KIND) :: m1, m2, m3 DOUBLE PRECISION :: vol1, vol2, vol3 CHARACTER(len=*) :: inclusion - COMPLEX*16 :: beta2, beta3, m1t, m2t, m3t + COMPLEX(KIND=R8KIND) :: beta2, beta3, m1t, m2t, m3t INTEGER, INTENT(out) :: error error = 0 @@ -639,7 +644,7 @@ COMPLEX*16 FUNCTION m_complex_maxwellgarnett(vol1, vol2, vol3, & #else CALL wrf_debug(150, radar_debug) #endif - m_complex_maxwellgarnett=DCMPLX(-999.99d0,-999.99d0) + m_complex_maxwellgarnett=CMPLX(-999.99d0,-999.99d0,kind=R8KIND) error = 1 return endif diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F index a2d28456b7..8e24340501 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson.F @@ -1,4 +1,7 @@ !================================================================================================================= +!reference: WRF-v4.1.4 +!Laura D. Fowler (laura@ucar.edu) / 2020-01-10. + !module_mp_thompson was originally copied from./phys/module_mp_thompson.F from WRF version 3.8. Modifications made !to the original sourcecode are mostly confined to subroutine thompson_init. !Laura D. Fowler (laura@ucar.edu) / 2016-06-04. @@ -11,7 +14,18 @@ ! Laura D. Fowler (laura@ucar.edu) / 2016-10-29. ! * in subroutine mp_gt_driver, moved the initialization of variables Nt_c and mu_c ! before initialization of local mixing ratios and number concentrations. -! Laura D. Fowler (lara@ucar.edu) / 2916-12-30. +! Laura D. Fowler (laura@ucar.edu) / 2016-12-30. +! * in subroutine freezeH2O, modified the calculation of the variable prob, following +! Greg Thompson for the release of WRF version 3.9.0. +! Laura D. Fowler (laura@ucar.edu) / 2017-03-27. +! * in subroutine mp_gt_driver, added the variables vqr, vqi, vqs, and vqg to output the +! mean mass-weighted fall velocities of rain, cloud ice, snow, and graupel to compute +! diagnostics of lightning flash rates. +! Laura D. Fowler (laura@ucar.edu) / 2017-04-19. +! * in subroutine mp_gt_driver, changed the declarations of arrays vqg1d, vqid1,vqr1d, and vqs1d, +! from (kts:kte) to (kts:kte+1) to match the dimensions of arrays vtgk, vtik, vtsk, and vtrk, in +! subroutine mp_thompson. +! Laura D. Fowler (laura@ucar.edu) / 2017-08-31. !+---+-----------------------------------------------------------------+ @@ -52,7 +66,7 @@ !.. Remaining values should probably be left alone. !.. !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 01 Aug 2016 Aerosol additions to v3.5.1 code 9/2013 +!..Last modified: 24 Jan 2018 Aerosol additions to v3.5.1 code 9/2013 !.. Cloud fraction additions 11/2014 part of pre-v3.7 !+---+-----------------------------------------------------------------+ !wrft:model_layer:physics @@ -60,10 +74,12 @@ ! MODULE module_mp_thompson + use mpas_log use mpas_kind_types use mpas_atmphys_functions, only: gammp,wgamma,rslf,rsif use mpas_atmphys_utilities - use module_mp_radar + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + use mp_radar implicit none logical, parameter, private:: iiwarm = .false. @@ -89,6 +105,8 @@ MODULE module_mp_thompson !.. scheme. In 2-moment cloud water, Nt_c represents a maximum of !.. droplet concentration and nu_c is also variable depending on local !.. droplet number concentration. +!.. MPAS: Nt_c is initialized to 100.E6 over oceans and 300.E6 over land as +! a function of landmask in subroutine init_thompson_clouddroplets_forMPAS. ! REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6 REAL, PARAMETER, PRIVATE:: Nt_c_max = 1999.E6 REAL, PRIVATE:: Nt_c @@ -96,10 +114,12 @@ MODULE module_mp_thompson !..Declaration of constants for assumed CCN/IN aerosols when none in !.. the input data. Look inside the init routine for modifications !.. due to surface land-sea points or vegetation characteristics. - REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6 - REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6 - REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6 - REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6 +!.. MPAS: naIN0, naIN1, naCCN0, and naCCN1 are used in init_thompson_aerosols_forMPAS +!.. for initialization of nwfa. and nifa. + REAL, PARAMETER, PUBLIC:: naIN0 = 1.5E6 + REAL, PARAMETER, PUBLIC:: naIN1 = 0.5E6 + REAL, PARAMETER, PUBLIC:: naCCN0 = 300.0E6 + REAL, PARAMETER, PUBLIC:: naCCN1 = 50.0E6 !..Generalized gamma distributions for rain, graupel and cloud ice. !.. N(D) = N_0 * D**mu * exp(-lamda*D); mu=0 is exponential. @@ -234,12 +254,12 @@ MODULE module_mp_thompson INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55 INTEGER, PARAMETER, PRIVATE:: ntb_t = 9 INTEGER, PRIVATE:: nic1, nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3 - INTEGER, PARAMETER, PRIVATE:: ntb_arc = 7 - INTEGER, PARAMETER, PRIVATE:: ntb_arw = 9 - INTEGER, PARAMETER, PRIVATE:: ntb_art = 7 - INTEGER, PARAMETER, PRIVATE:: ntb_arr = 5 - INTEGER, PARAMETER, PRIVATE:: ntb_ark = 4 - INTEGER, PARAMETER, PRIVATE:: ntb_IN = 55 + INTEGER, PARAMETER, PUBLIC:: ntb_arc = 7 + INTEGER, PARAMETER, PUBLIC:: ntb_arw = 9 + INTEGER, PARAMETER, PUBLIC:: ntb_art = 7 + INTEGER, PARAMETER, PUBLIC:: ntb_arr = 5 + INTEGER, PARAMETER, PUBLIC:: ntb_ark = 4 + INTEGER, PARAMETER, PUBLIC:: ntb_IN = 55 INTEGER, PRIVATE:: niIN2 DOUBLE PRECISION, DIMENSION(nbins+1):: xDx @@ -421,6 +441,7 @@ subroutine thompson_init(l_mp_tables) integer:: i,j,k,l,m,n integer:: istat logical:: micro_init + integer:: mp_unit !..Allocate space for lookup tables (J. Michalakes 2009Jun08). micro_init = .FALSE. @@ -659,7 +680,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0i*1.0d0 xDx(nbi+1) = 5.0d0*D0s do n = 2, nbi - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbi) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbi,KIND=R8SIZE) & *DLOG(xDx(nbi+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbi @@ -671,7 +692,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0r*1.0d0 xDx(nbr+1) = 0.005d0 do n = 2, nbr - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbr) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbr,KIND=R8SIZE) & *DLOG(xDx(nbr+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbr @@ -683,7 +704,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0s*1.0d0 xDx(nbs+1) = 0.02d0 do n = 2, nbs - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbs) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbs,KIND=R8SIZE) & *DLOG(xDx(nbs+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbs @@ -695,7 +716,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = D0g*1.0d0 xDx(nbg+1) = 0.05d0 do n = 2, nbg - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbg) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbg,KIND=R8SIZE) & *DLOG(xDx(nbg+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbg @@ -707,7 +728,7 @@ subroutine thompson_init(l_mp_tables) xDx(1) = 1.0d0 xDx(nbc+1) = 3000.0d0 do n = 2, nbc - xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc) & + xDx(n) = DEXP(REAL(n-1,KIND=R8SIZE)/REAL(nbc,KIND=R8SIZE) & *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1))) enddo do n = 1, nbc @@ -833,18 +854,23 @@ subroutine thompson_init(l_mp_tables) call table_dropEvap !..Rain collecting graupel & graupel collecting rain. - open(unit=11,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & +#if defined(mpas) + call mpas_new_unit(mp_unit, unformatted = .true.) +#else + mp_unit = 11 +#endif + open(unit=mp_unit,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat = istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_QRacrQG.DBL') - read(11) tcg_racg - read(11) tmr_racg - read(11) tcr_gacr - read(11) tmg_gacr - read(11) tnr_racg - read(11) tnr_gacr - close(unit=11) + read(mp_unit) tcg_racg + read(mp_unit) tmr_racg + read(mp_unit) tcr_gacr + read(mp_unit) tmg_gacr + read(mp_unit) tnr_racg + read(mp_unit) tnr_gacr + close(unit=mp_unit) ! write(0,*) '--- end read MP_THOMPSON_QRacrQG.DBL' ! write(0,*) 'max tcg_racg =',maxval(tcg_racg) ! write(0,*) 'min tcg_racg =',minval(tcg_racg) @@ -860,24 +886,24 @@ subroutine thompson_init(l_mp_tables) ! write(0,*) 'min tnr_gacr =',minval(tnr_gacr) !..Rain collecting snow & snow collecting rain. - open(unit=11,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & + open(unit=mp_unit,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat=istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_QRacrQS.DBL') - read(11) tcs_racs1 - read(11) tmr_racs1 - read(11) tcs_racs2 - read(11) tmr_racs2 - read(11) tcr_sacr1 - read(11) tms_sacr1 - read(11) tcr_sacr2 - read(11) tms_sacr2 - read(11) tnr_racs1 - read(11) tnr_racs2 - read(11) tnr_sacr1 - read(11) tnr_sacr2 - close(unit=11) + read(mp_unit) tcs_racs1 + read(mp_unit) tmr_racs1 + read(mp_unit) tcs_racs2 + read(mp_unit) tmr_racs2 + read(mp_unit) tcr_sacr1 + read(mp_unit) tms_sacr1 + read(mp_unit) tcr_sacr2 + read(mp_unit) tms_sacr2 + read(mp_unit) tnr_racs1 + read(mp_unit) tnr_racs2 + read(mp_unit) tnr_sacr1 + read(mp_unit) tnr_sacr2 + close(unit=mp_unit) ! write(0,*) '--- end read MP_THOMPSON_QRacrQS.DBL' ! write(0,*) 'max tcs_racs1 =',maxval(tcs_racs1) ! write(0,*) 'min tcs_racs1 =',minval(tcs_racs1) @@ -905,18 +931,18 @@ subroutine thompson_init(l_mp_tables) ! write(0,*) 'min tnr_sacr2 =',minval(tnr_sacr2) !..Cloud water and rain freezing (Bigg, 1953). - open(unit=11,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & + open(unit=mp_unit,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat=istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_freezeH2O.DBL') - read(11) tpi_qrfz - read(11) tni_qrfz - read(11) tpg_qrfz - read(11) tnr_qrfz - read(11) tpi_qcfz - read(11) tni_qcfz - close(unit=11) + read(mp_unit) tpi_qrfz + read(mp_unit) tni_qrfz + read(mp_unit) tpg_qrfz + read(mp_unit) tnr_qrfz + read(mp_unit) tpi_qcfz + read(mp_unit) tni_qcfz + close(unit=mp_unit) ! write(0,*) '--- end read MP_THOMPSON_freezeH2O.DBL:' ! write(0,*) 'max tpi_qrfz =',maxval(tpi_qrfz) ! write(0,*) 'min tpi_qrfz =',minval(tpi_qrfz) @@ -932,15 +958,18 @@ subroutine thompson_init(l_mp_tables) ! write(0,*) 'min tni_qcfz =',minval(tni_qcfz) !..Conversion of some ice mass into snow category. - open(unit=11,file='MP_THOMPSON_QIautQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & + open(unit=mp_unit,file='MP_THOMPSON_QIautQS_DATA.DBL',form='UNFORMATTED',status='OLD',action='READ', & iostat=istat) if(istat /= open_OK) & call physics_error_fatal('subroutine thompson_init: ' // & 'failure opening MP_THOMPSON_QIautQS.DBL') - read(11) tpi_ide - read(11) tps_iaus - read(11) tni_iaus - close(unit=11) + read(mp_unit) tpi_ide + read(mp_unit) tps_iaus + read(mp_unit) tni_iaus + close(unit=mp_unit) +#if defined(mpas) + call mpas_release_unit(mp_unit) +#endif ! write(0,*) '--- end read MP_THOMPSON_QIautQS.DBL ' ! write(0,*) 'max tps_iaus =',maxval(tps_iaus) ! write(0,*) 'min tps_iaus =',minval(tps_iaus) @@ -969,17 +998,18 @@ END SUBROUTINE thompson_init !+---+-----------------------------------------------------------------+ !..This is a wrapper routine designed to transfer values from 3D to 1D. !+---+-----------------------------------------------------------------+ - SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & - nwfa, nifa, nwfa2d, & - th, pii, p, w, dz, dt_in, itimestep, & - RAINNC, RAINNCV, & - SNOWNC, SNOWNCV, & - GRAUPELNC, GRAUPELNCV, SR, & + SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & + nwfa, nifa, nwfa2d, nifa2d, & + th, pii, p, w, dz, dt_in, itimestep, & + RAINNC, RAINNCV, & + SNOWNC, SNOWNCV, & + GRAUPELNC, GRAUPELNCV, SR, & + rainprod, evapprod, & refl_10cm, diagflag, do_radar_ref, & re_cloud, re_ice, re_snow, & has_reqc, has_reqi, has_reqs, & #if defined(mpas) - ntc,muc,rainprod,evapprod, & + ntc,muc, & #endif ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -995,7 +1025,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qv, qc, qr, qi, qs, qg, ni, nr, th REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & nc, nwfa, nifa - REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d + REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d, nifa2d REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & re_cloud, re_ice, re_snow INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs @@ -1005,11 +1035,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & RAINNC, RAINNCV, SR REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT):: & SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: & + rainprod,evapprod #if defined(mpas) REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN):: & ntc,muc - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & - rainprod,evapprod REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT), OPTIONAL:: & refl_10cm #else @@ -1025,10 +1055,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, rho, dBZ REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d -#if defined(mpas) - REAL, DIMENSION(kts:kte):: & - rainprod1d, evapprod1d -#endif + REAL, DIMENSION(kts:kte):: rainprod1d, evapprod1d REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic REAL:: dt, pptrain, pptsnow, pptgraul, pptice REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max @@ -1040,7 +1067,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & INTEGER:: i_start, j_start, i_end, j_end LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref - CHARACTER*256:: mp_debug +! CHARACTER*256:: mp_debug !+---+ @@ -1088,9 +1115,9 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qg = 0 kmax_ni = 0 kmax_nr = 0 - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo +! do i = 1, 256 +! mp_debug(i:i) = char(0) +! enddo ! if (.NOT. is_aerosol_aware .AND. PRESENT(nc) .AND. PRESENT(nwfa) & ! .AND. PRESENT(nifa) .AND. PRESENT(nwfa2d)) then @@ -1118,6 +1145,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & Nt_c = ntc(i,j) mu_c = muc(i,j) #endif + do k = kts,kte + rainprod1d(k) = 0. + evapprod1d(k) = 0. + enddo + do k = kts, kte t1d(k) = th(i,k,j)*pii(i,k,j) p1d(k) = p(i,k,j) @@ -1131,6 +1163,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & qg1d(k) = qg(i,k,j) ni1d(k) = ni(i,k,j) nr1d(k) = nr(i,k,j) + rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) enddo if (is_aerosol_aware) then do k = kts, kte @@ -1141,7 +1174,6 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa1 = nwfa2d(i,j) else do k = kts, kte - rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) nc1d(k) = Nt_c/rho(k) nwfa1d(k) = 11.1E6/rho(k) nifa1d(k) = naIN1*0.01/rho(k) @@ -1151,10 +1183,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, & - pptrain, pptsnow, pptgraul, pptice, & -#if defined(mpas) - rainprod1d, evapprod1d, & -#endif + pptrain, pptsnow, pptgraul, pptice, & + rainprod1d, evapprod1d, & kts, kte, dt, i, j) pcp_ra(i,j) = pptrain @@ -1181,6 +1211,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & if (is_aerosol_aware) then !-GT nwfa1d(kts) = nwfa1 nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt_in + nifa1d(kts) = nifa1d(kts) + nifa2d(i,j)*dt_in do k = kts, kte nc(i,k,j) = nc1d(k) @@ -1209,8 +1240,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qc = k qc_max = qc1d(k) elseif (qc1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative qc $r at i,j,k = $i $i $i ', & + realArgs=(/qc1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative qc ', qc1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (qr1d(k) .gt. qr_max) then @@ -1219,8 +1252,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qr = k qr_max = qr1d(k) elseif (qr1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative qr $r at i,j,k = $i $i $i ', & + realArgs=(/qr1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative qr ', qr1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (nr1d(k) .gt. nr_max) then @@ -1229,8 +1264,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_nr = k nr_max = nr1d(k) elseif (nr1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative nr ', nr1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative nr $r at i,j,k = $i $i $i ', & + realArgs=(/nr1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative nr ', nr1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (qs1d(k) .gt. qs_max) then @@ -1239,8 +1276,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qs = k qs_max = qs1d(k) elseif (qs1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative qs $r at i,j,k = $i $i $i ', & + realArgs=(/qs1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative qs ', qs1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (qi1d(k) .gt. qi_max) then @@ -1249,8 +1288,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qi = k qi_max = qi1d(k) elseif (qi1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative qi $r at i,j,k = $i $i $i ', & + realArgs=(/qi1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative qi ', qi1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (qg1d(k) .gt. qg_max) then @@ -1259,8 +1300,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_qg = k qg_max = qg1d(k) elseif (qg1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative qg $r at i,j,k = $i $i $i ', & + realArgs=(/qg1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative qg ', qg1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (ni1d(k) .gt. ni_max) then @@ -1269,21 +1312,31 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & kmax_ni = k ni_max = ni1d(k) elseif (ni1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), & - ' at i,j,k=', i,j,k + call mpas_log_write('--- WARNING, negative qni $r at i,j,k = $i $i $i ', & + realArgs=(/ni1d(k)/),intArgs=(/i,j,k/)) +! write(mp_debug,*) 'WARNING, negative ni ', ni1d(k), & +! ' at i,j,k=', i,j,k ! CALL wrf_debug(150, mp_debug) endif if (qv1d(k) .lt. 0.0) then - write(mp_debug,*) 'WARNING, negative qv ', qv1d(k), & - ' at i,j,k=', i,j,k -! CALL wrf_debug(150, mp_debug) + call mpas_log_write('--- WARNING, negative qv $r at i,j,k = $i $i $i ', & + realArgs=(/qv1d(k)/),intArgs=(/i,j,k/)) if (k.lt.kte-2 .and. k.gt.kts+1) then - write(mp_debug,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) -! CALL wrf_debug(150, mp_debug) + call mpas_log_write('-- below and above are: $r $r',realArgs=(/qv(i,k-1,j), qv(i,k+1,j)/)) qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) else qv(i,k,j) = 1.E-7 endif +! write(mp_debug,*) 'WARNING, negative qv ', qv1d(k), & +! ' at i,j,k=', i,j,k +! CALL wrf_debug(150, mp_debug) +! if (k.lt.kte-2 .and. k.gt.kts+1) then +! write(mp_debug,*) ' below and above are: ', qv(i,k-1,j), qv(i,k+1,j) +! CALL wrf_debug(150, mp_debug) +! qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j))) +! else +! qv(i,k,j) = 1.E-7 +! endif endif enddo @@ -1316,20 +1369,20 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & enddo j_loop ! DEBUG - GT - write(mp_debug,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & - 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & - 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & - 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & - 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & - 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & - 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', & - 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' +! write(mp_debug,'(a,7(a,e13.6,1x,a,i3,a,i3,a,i3,a,1x))') 'MP-GT:', & +! 'qc: ', qc_max, '(', imax_qc, ',', jmax_qc, ',', kmax_qc, ')', & +! 'qr: ', qr_max, '(', imax_qr, ',', jmax_qr, ',', kmax_qr, ')', & +! 'qi: ', qi_max, '(', imax_qi, ',', jmax_qi, ',', kmax_qi, ')', & +! 'qs: ', qs_max, '(', imax_qs, ',', jmax_qs, ',', kmax_qs, ')', & +! 'qg: ', qg_max, '(', imax_qg, ',', jmax_qg, ',', kmax_qg, ')', & +! 'ni: ', ni_max, '(', imax_ni, ',', jmax_ni, ',', kmax_ni, ')', & +! 'nr: ', nr_max, '(', imax_nr, ',', jmax_nr, ',', kmax_nr, ')' ! CALL wrf_debug(150, mp_debug) ! END DEBUG - GT - do i = 1, 256 - mp_debug(i:i) = char(0) - enddo +! do i = 1, 256 +! mp_debug(i:i) = char(0) +! enddo END SUBROUTINE mp_gt_driver @@ -1344,12 +1397,10 @@ END SUBROUTINE mp_gt_driver !.. Thompson et al. (2004, 2008). !+---+-----------------------------------------------------------------+ ! - subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & + subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & - pptrain, pptsnow, pptgraul, pptice, & -#if defined(mpas) - rainprod, evapprod, & -#endif + pptrain, pptsnow, pptgraul, pptice, & + rainprod, evapprod, & kts, kte, dt, ii, jj) implicit none @@ -1362,10 +1413,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt -#if defined(mpas) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod -#endif !..Local variables REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, & @@ -1439,7 +1488,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL:: r_frac, g_frac REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr REAL:: Ef_ra, Ef_sa, Ef_ga - REAL:: dtsave, odts, odt, odzq, hgt_agl + REAL:: dtsave, odts, odt, odzq, hgt_agl, SR REAL:: xslw1, ygra1, zans1, eva_factor INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq INTEGER, DIMENSION(5):: ksed1 @@ -1453,9 +1502,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & CHARACTER*256:: mp_debug INTEGER:: nu_c +! modifications proposed by Ted Mansell for MPAS. +! Laura D. Fowler (laura@ucar.edu) / 2017-03-27. +! real, parameter:: mvd_r_breakup = 1.e-3 +!... end modifications. + LOGICAL, DIMENSION(kts:kte):: L_nifa,L_nwfa + REAL:: tem !+---+ - debug_flag = .false. ! if (ii.eq.901 .and. jj.eq.379) debug_flag = .true. if(debug_flag) then @@ -1566,12 +1620,19 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnd_scd(k) = 0. pnd_gcd(k) = 0. enddo -#if defined(mpas) do k = kts, kte rainprod(k) = 0. evapprod(k) = 0. enddo -#endif +!.. initialize the logicals L_nifa and L_nwfa used to detect instances of the cloud +!.. ice and cloud liquid water mixing ratios being greater than R1 but their number +!.. concentration being less than 2. and R2: + if(is_aerosol_aware) then + do k = kts, kte + L_nifa(k) = .false. + L_nwfa(k) = .false. + enddo + endif !..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments. do k = kts, kte @@ -1583,6 +1644,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & smod(k) = 0. smoe(k) = 0. smof(k) = 0. + mvd_r(k) = 0. + mvd_c(k) = 0. enddo !+---+-----------------------------------------------------------------+ @@ -1599,8 +1662,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (qc1d(k) .gt. R1) then no_micro = .false. rc(k) = qc1d(k)*rho(k) - nc(k) = MAX(2., nc1d(k)*rho(k)) + nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) L_qc(k) = .true. +!.. set L_nwfa to true when the cloud liquid water number concentration is less than 2.: + if(is_aerosol_aware .and. nc(k) .le. 2.) L_nwfa(k) = .true. nu_c = MIN(15, NINT(1000.E6/nc(k)) + 2) lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr xDc = (bm_r + nu_c + 1.) / lamc @@ -1624,17 +1689,20 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & no_micro = .false. ri(k) = qi1d(k)*rho(k) ni(k) = MAX(R2, ni1d(k)*rho(k)) + L_qi(k) = .true. +!.. set L_nifa to true when the cloud ice number concentration is less than R2: + if(is_aerosol_aware .and. ni(k) .le. R2) L_nifa(k) = .true. if (ni(k).le. R2) then - lami = cie(2)/25.E-6 - ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + lami = cie(2)/5.E-6 + ni(k) = MIN(9999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) endif - L_qi(k) = .true. +! L_qi(k) = .true. lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) + ni(k) = MIN(9999.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i @@ -1913,7 +1981,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & tau = 3.72/(rc(k)*taud) prr_wau(k) = zeta/tau prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k)) - pnr_wau(k) = prr_wau(k) / (am_r*nu_c*D0r*D0r*D0r) ! RAIN2M + pnr_wau(k) = prr_wau(k) / (am_r*nu_c*200.*D0r*D0r*D0r) ! RAIN2M pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k) & / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k))) ! Qc2M endif @@ -1952,8 +2020,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Compute all frozen hydrometeor species' process terms. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then + !..vts_boost is the factor applied to snow terminal + !..fallspeed due to riming of snow do k = kts, kte - vts_boost(k) = 1.5 + vts_boost(k) = 1.0 + xDs = 0.0 + if (L_qs(k)) xDs = smoc(k) / smob(k) !..Temperature lookup table indexes. tempc = temp(k) - 273.15 @@ -2105,13 +2177,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Snow collecting cloud water. In CE, assume Dc< mvd_r_breakup ) then + pnr_rcg(k) = -5.0*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M +! else +! pnr_rcg(k) = -3.0*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M +! endif endif endif endif @@ -2275,8 +2351,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnr_rfz(k) = MIN(DBLE(nr(k)*odts), pnr_rfz(k)) elseif (rr(k).gt. R1 .and. temp(k).lt.HGFR) then pri_rfz(k) = rr(k)*odts - pnr_rfz(k) = nr(k)*odts ! RAIN2M - pni_rfz(k) = pnr_rfz(k) + pni_rfz(k) = nr(k)*odts ! RAIN2M endif if (rc(k).gt. r_c(1)) then @@ -2307,7 +2382,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if (is_aerosol_aware .AND. homogIce .AND. (xni.le.500.E3) & + if (is_aerosol_aware .AND. homogIce .AND. (xni.le.999.E3) & & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts @@ -2430,7 +2505,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prs_sde(k).gt.eps) then r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k)) g_frac = MIN(0.95, 0.15 + (r_frac-2.)*.028) - vts_boost(k) = MIN(1.5, 1.1 + (r_frac-2.)*.016) + vts_boost(k) = MIN(1.5, 1.1 + (r_frac-2.)*.014) prg_scw(k) = g_frac*prs_scw(k) prs_scw(k) = (1. - g_frac)*prs_scw(k) endif @@ -2442,12 +2517,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & if (L_qs(k)) then prr_sml(k) = (tempc*tcond(k)-lvap0*diffu(k)*delQvs(k)) & * (t1_qs_me*smo1(k) + t2_qs_me*rhof2(k)*vsc2(k)*smof(k)) - prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & - * (prr_rcs(k)+prs_scw(k)) + if (prr_sml(k) .gt. 0.) then + prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc & + * (prr_rcs(k)+prs_scw(k)) + endif prr_sml(k) = MIN(DBLE(rs(k)*odts), MAX(0.D0, prr_sml(k))) pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc) ! RAIN2M pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k)) -! if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0 if (ssati(k).lt. 0.) then prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & @@ -2466,7 +2542,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prr_gml(k) = MIN(DBLE(rg(k)*odts), MAX(0.D0, prr_gml(k))) pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k) & ! RAIN2M * prr_gml(k) * 10.0**(-0.5*tempc) -! if (tempc.gt.7.5 .or. rg(k).lt.0.005E-3) pnr_gml(k)=0.0 if (ssati(k).lt. 0.) then prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs & @@ -2502,7 +2577,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !.. supersat again. sump = pri_inu(k) + pri_ide(k) + prs_ide(k) & + prs_sde(k) + prg_gde(k) + pri_iha(k) - rate_max = (qv(k)-qvsi(k))*odts*0.999 + rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999 if ( (sump.gt. eps .and. sump.gt. rate_max) .or. & (sump.lt. -eps .and. sump.lt. rate_max) ) then ratio = rate_max/sump @@ -2675,7 +2750,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & xDi = (bm_i + mu_i + 1.) * ilami if (xDi.lt. 5.E-6) then lami = cie(2)/5.E-6 - xni = MIN(499.D3, cig(1)*oig2*xri/am_i*lami**bm_i) + xni = MIN(9999.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -2686,8 +2761,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & niten(k) = -ni1d(k)*odts endif xni=MAX(0.,(ni1d(k) + niten(k)*dtsave)*rho(k)) - if (xni.gt.499.E3) & - niten(k) = (499.E3-ni1d(k)*rho(k))*odts*orho + if (xni.gt.9999.E3) & + niten(k) = (9999.E3-ni1d(k)*rho(k))*odts*orho !..Rain tendency qrten(k) = qrten(k) + (prr_wau(k) + prr_rcw(k) & @@ -2699,7 +2774,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Rain number tendency nrten(k) = nrten(k) + (pnr_wau(k) + pnr_sml(k) + pnr_gml(k) & - (pnr_rfz(k) + pnr_rcr(k) + pnr_rcg(k) & - + pnr_rcs(k) + pnr_rci(k)) ) & + + pnr_rcs(k) + pnr_rci(k) + pni_rfz(k)) ) & * orho !..Rain mass/number balance; keep median volume diameter between @@ -2787,10 +2862,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lvt2(k)=lvap(k)*lvap(k)*ocp(k)*oRv*otemp*otemp nwfa(k) = MAX(11.1E6, (nwfa1d(k) + nwfaten(k)*DT)*rho(k)) + enddo + do k = kts, kte if ((qc1d(k) + qcten(k)*DT) .gt. R1) then rc(k) = (qc1d(k) + qcten(k)*DT)*rho(k) - nc(k) = MAX(2., (nc1d(k) + ncten(k)*DT)*rho(k)) + nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. is_aerosol_aware) nc(k) = Nt_c L_qc(k) = .true. else @@ -2852,6 +2929,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !.. intercepts/slopes of graupel and rain. !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then + do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smod(k) = 0. + enddo do k = kts, kte if (.not. L_qs(k)) CYCLE tc0 = MIN(-0.1, temp(k)-273.15) @@ -3019,9 +3102,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & ! -tpc_wev(idx_d, idx_c, idx_n)*orho*odt) prw_vcd(k) = MAX(DBLE(-rc(k)*0.99*orho*odt), prw_vcd(k)) pnc_wcd(k) = MAX(DBLE(-nc(k)*0.99*orho*odt), & - DBLE(-tnc_wev(idx_d, idx_c, idx_n)*orho*odt)) + -tnc_wev(idx_d, idx_c, idx_n)*orho*odt) endif + if(is_aerosol_aware .and. L_nwfa(k)) L_nwfa(k) = .false. else prw_vcd(k) = -rc(k)*orho*odt pnc_wcd(k) = -nc(k)*orho*odt @@ -3035,7 +3119,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nwfaten(k) = nwfaten(k) - pnc_wcd(k) tten(k) = tten(k) + lvap(k)*ocp(k)*prw_vcd(k)*(1-IFDRY) rc(k) = MAX(R1, (qc1d(k) + DT*qcten(k))*rho(k)) - nc(k) = MAX(2., (nc1d(k) + DT*ncten(k))*rho(k)) + if (rc(k).eq.R1) L_qc(k) = .false. + nc(k) = MAX(2., MIN((nc1d(k)+ncten(k)*DT)*rho(k), Nt_c_max)) if (.NOT. is_aerosol_aware) nc(k) = Nt_c qv(k) = MAX(1.E-10, qv1d(k) + DT*qvten(k)) temp(k) = t1d(k) + DT*tten(k) @@ -3096,7 +3181,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prv_rev(k) = MIN(DBLE(rate_max), prv_rev(k)*orho) !..TEST: G. Thompson 10 May 2013 -!..Reduce the rain evaporation in same places as melting graupel occurs. +!..Reduce the rain evaporation in same places as melting graupel occurs. !..Rationale: falling and simultaneous melting graupel in subsaturated !..regions will not melt as fast because particle temperature stays !..at 0C. Also not much shedding of the water from the graupel so @@ -3124,7 +3209,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) endif enddo -#if defined(mpas) do k = kts, kte evapprod(k) = prv_rev(k) - (min(zeroD0,prs_sde(k)) + & min(zeroD0,prg_gde(k))) @@ -3133,7 +3217,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prg_gcw(k) + prs_sci(k) + & pri_rci(k) enddo -#endif !+---+-----------------------------------------------------------------+ !..Find max terminal fallspeed (distribution mass-weighted mean @@ -3156,6 +3239,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtck(k) = 0. vtnck(k) = 0. enddo + + if (ANY(L_qr .eqv. .true.)) then do k = kte, kts, -1 vtr = 0. rhof(k) = SQRT(RHO_NOT/rho(k)) @@ -3186,9 +3271,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo if (ksed1(1) .eq. kte) ksed1(1) = kte-1 if (nstep .gt. 0) onstep(1) = 1./REAL(nstep) + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qc .eqv. .true.)) then hgt_agl = 0. do k = kts, kte-1 if (rc(k) .gt. R2) ksed1(5) = k @@ -3209,11 +3296,13 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & vtnck(k) = vtc endif enddo + endif !+---+-----------------------------------------------------------------+ if (.not. iiwarm) then + if (ANY(L_qi .eqv. .true.)) then nstep = 0 do k = kte, kts, -1 vti = 0. @@ -3241,9 +3330,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo if (ksed1(2) .eq. kte) ksed1(2) = kte-1 if (nstep .gt. 0) onstep(2) = 1./REAL(nstep) + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qs .eqv. .true.)) then nstep = 0 do k = kte, kts, -1 vts = 0. @@ -3261,8 +3352,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) if (temp(k).gt. (T_0+0.1)) then - vtsk(k) = MAX(vts*vts_boost(k), & - & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) + SR = rs(k)/(rs(k)+rr(k)) + vtsk(k) = vts*SR + (1.-SR)*vtrk(k) else vtsk(k) = vts*vts_boost(k) endif @@ -3278,9 +3369,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo if (ksed1(3) .eq. kte) ksed1(3) = kte-1 if (nstep .gt. 0) onstep(3) = 1./REAL(nstep) + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qg .eqv. .true.)) then nstep = 0 do k = kte, kts, -1 vtg = 0. @@ -3304,18 +3397,16 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & enddo if (ksed1(4) .eq. kte) ksed1(4) = kte-1 if (nstep .gt. 0) onstep(4) = 1./REAL(nstep) + endif endif !+---+-----------------------------------------------------------------+ !..Sedimentation of mixing ratio is the integral of v(D)*m(D)*N(D)*dD, !.. whereas neglect m(D) term for number concentration. Therefore, !.. cloud ice has proper differential sedimentation. -!.. New in v3.0+ is computing separate for rain, ice, snow, and -!.. graupel species thus making code faster with credit to J. Schmidt. -!.. Bug fix, 2013Nov01 to tendencies using rho(k+1) correction thanks to -!.. Eric Skyllingstad. !+---+-----------------------------------------------------------------+ + if (ANY(L_qr .eqv. .true.)) then nstep = NINT(1./onstep(1)) do n = 1, nstep do k = kte, kts, -1 @@ -3342,12 +3433,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(1)) enddo - if (rr(kts).gt.R1*10.) & + if (rr(kts).gt.R1*1000.) & pptrain = pptrain + sed_r(kts)*DT*onstep(1) enddo + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qc .eqv. .true.)) then do k = kte, kts, -1 sed_c(k) = vtck(k)*rc(k) sed_n(k) = vtnck(k)*nc(k) @@ -3360,9 +3453,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rc(k) = MAX(R1, rc(k) + (sed_c(k+1)-sed_c(k)) *odzq*DT) nc(k) = MAX(10., nc(k) + (sed_n(k+1)-sed_n(k)) *odzq*DT) enddo + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qi .eqv. .true.)) then nstep = NINT(1./onstep(2)) do n = 1, nstep do k = kte, kts, -1 @@ -3389,12 +3484,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(2)) enddo - if (ri(kts).gt.R1*10.) & + if (ri(kts).gt.R1*1000.) & pptice = pptice + sed_i(kts)*DT*onstep(2) enddo + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qs .eqv. .true.)) then nstep = NINT(1./onstep(3)) do n = 1, nstep do k = kte, kts, -1 @@ -3414,12 +3511,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(3)) enddo - if (rs(kts).gt.R1*10.) & + if (rs(kts).gt.R1*1000.) & pptsnow = pptsnow + sed_s(kts)*DT*onstep(3) enddo + endif !+---+-----------------------------------------------------------------+ + if (ANY(L_qg .eqv. .true.)) then nstep = NINT(1./onstep(4)) do n = 1, nstep do k = kte, kts, -1 @@ -3439,9 +3538,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & *odzq*DT*onstep(4)) enddo - if (rg(kts).gt.R1*10.) & + if (rg(kts).gt.R1*1000.) & pptgraul = pptgraul + sed_g(kts)*DT*onstep(4) enddo + endif !+---+-----------------------------------------------------------------+ !.. Instantly melt any cloud ice into cloud water if above 0C and @@ -3478,10 +3578,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t1d(k) = t1d(k) + tten(k)*DT qv1d(k) = MAX(1.E-10, qv1d(k) + qvten(k)*DT) qc1d(k) = qc1d(k) + qcten(k)*DT - nc1d(k) = MAX(2./rho(k), nc1d(k) + ncten(k)*DT) - nwfa1d(k) = MAX(11.1E6/rho(k), MIN(9999.E6/rho(k), & + nc1d(k) = MAX(2./rho(k), MIN(nc1d(k) + ncten(k)*DT, Nt_c_max)) + nwfa1d(k) = MAX(11.1E6, MIN(9999.E6, & (nwfa1d(k)+nwfaten(k)*DT))) - nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6/rho(k), & + nifa1d(k) = MAX(naIN1*0.01, MIN(9999.E6, & (nifa1d(k)+nifaten(k)*DT))) if (qc1d(k) .le. R1) then @@ -3515,7 +3615,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = cie(2)/300.E-6 endif ni1d(k) = MIN(cig(1)*oig2*qi1d(k)/am_i*lami**bm_i, & - 499.D3/rho(k)) + 9999.D3/rho(k)) endif qr1d(k) = qr1d(k) + qrten(k)*DT nr1d(k) = MAX(R2/rho(k), nr1d(k) + nrten(k)*DT) @@ -3628,7 +3728,8 @@ subroutine qr_acr_qg tcg_racg(i,j,k,m) = t1 tmr_racg(i,j,k,m) = DMIN1(z1, r_r(m)*1.0d0) tcr_gacr(i,j,k,m) = t2 - tmg_gacr(i,j,k,m) = z2 + tmg_gacr(i,j,k,m) = DMIN1(z2, r_g(j)*1.0d0) + !DAVE tmg_gacr(i,j,k,m) = DMIN1(z2, DBLE(r_g(j))) tnr_racg(i,j,k,m) = y1 tnr_gacr(i,j,k,m) = y2 enddo @@ -3817,8 +3918,10 @@ subroutine freezeH2O !..Local variables INTEGER:: i, j, k, m, n, n2 - DOUBLE PRECISION, DIMENSION(nbr):: N_r, massr - DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc + INTEGER:: km, km_s, km_e + DOUBLE PRECISION:: N_r, N_c + DOUBLE PRECISION, DIMENSION(nbr):: massr + DOUBLE PRECISION, DIMENSION(nbc):: massc DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & prob, vol, Texp, orho_w, & lam_exp, lamr, N0_r, lamc, N0_c, y @@ -3836,12 +3939,16 @@ subroutine freezeH2O massc(n) = am_r*Dc(n)**bm_r enddo + km_s = 0 + km_e = ntb_IN*45 - 1 + !..Freeze water (smallest drops become cloud ice, otherwise graupel). - do m = 1, ntb_IN - T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) - do k = 1, 45 + do km = km_s, km_e + m = km / 45 + 1 + k = mod( km , 45 ) + 1 + T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) ! print*, ' Freezing water for temp = ', -k - Texp = DEXP( DFLOAT(k) - T_adjust*1.0D0 ) - 1.0D0 + Texp = DEXP( REAL(k,KIND=R8SIZE) - T_adjust*1.0D0 ) - 1.0D0 do j = 1, ntb_r1 do i = 1, ntb_r lam_exp = (N0r_exp(j)*am_r*crg(1)/r_r(i))**ore1 @@ -3852,15 +3959,15 @@ subroutine freezeH2O sumn1 = 0.0d0 sumn2 = 0.0d0 do n2 = nbr, 1, -1 - N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) + N_r = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2) vol = massr(n2)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) + prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)) if (massr(n2) .lt. xm0g) then - sumn1 = sumn1 + prob*N_r(n2) - sum1 = sum1 + prob*N_r(n2)*massr(n2) + sumn1 = sumn1 + prob*N_r + sum1 = sum1 + prob*N_r*massr(n2) else - sumn2 = sumn2 + prob*N_r(n2) - sum2 = sum2 + prob*N_r(n2)*massr(n2) + sumn2 = sumn2 + prob*N_r + sum2 = sum2 + prob*N_r*massr(n2) endif if ((sum1+sum2).ge.r_r(i)) EXIT enddo @@ -3880,10 +3987,10 @@ subroutine freezeH2O sumn2 = 0.0d0 do n = nbc, 1, -1 vol = massc(n)*orho_w - prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp) - N_c(n) = N0_c*Dc(n)**nu_c*EXP(-lamc*Dc(n))*dtc(n) - sumn2 = MIN(t_Nc(j), sumn2 + prob*N_c(n)) - sum1 = sum1 + prob*N_c(n)*massc(n) + prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)) + N_c = N0_c*Dc(n)**nu_c*EXP(-lamc*Dc(n))*dtc(n) + sumn2 = MIN(t_Nc(j), sumn2 + prob*N_c) + sum1 = sum1 + prob*N_c*massc(n) if (sum1 .ge. r_c(i)) EXIT enddo tpi_qcfz(i,j,k,m) = sum1 @@ -3891,9 +3998,9 @@ subroutine freezeH2O enddo enddo enddo - enddo end subroutine freezeH2O + !+---+-----------------------------------------------------------------+ !ctrlL !+---+-----------------------------------------------------------------+ @@ -4270,7 +4377,7 @@ subroutine table_ccnAct end subroutine table_ccnAct #endif -!^L +! !+---+-----------------------------------------------------------------+ !..Retrieve fraction of CCN that gets activated given the model temp, !.. vertical velocity, and available CCN concentration. The lookup @@ -4610,7 +4717,7 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) ! mux = hx*p_alpha*n_in*rho ! xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.) ! elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then - nifa_cc = nifa*RHO_NOT0*1.E-6/rho + nifa_cc = MAX(0.5, nifa*RHO_NOT0*1.E-6/rho) ! xni = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6) ! [DeMott, 2015] xni = (5.94e-5*(-tempc)**3.33) & ! [DeMott, 2010] * (nifa_cc**((-0.0264*(tempc))+0.0033)) @@ -4727,7 +4834,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & do k = kts, kte rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) rc(k) = MAX(R1, qc1d(k)*rho(k)) - nc(k) = MAX(R2, nc1d(k)*rho(k)) + nc(k) = MAX(2., MIN(nc1d(k)*rho(k), Nt_c_max)) if (.NOT. is_aerosol_aware) nc(k) = Nt_c if (rc(k).gt.R1 .and. nc(k).gt.R2) has_qc = .true. ri(k) = MAX(R1, qi1d(k)*rho(k)) @@ -4739,6 +4846,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & if (has_qc) then do k = kts, kte + re_qc1d(k) = 2.49E-6 if (rc(k).le.R1 .or. nc(k).le.R2) CYCLE if (nc(k).lt.100) then inu_c = 15 @@ -4754,14 +4862,16 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & if (has_qi) then do k = kts, kte + re_qi1d(k) = 2.49E-6 if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - re_qi1d(k) = MAX(5.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) + re_qi1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) enddo endif if (has_qs) then do k = kts, kte + re_qs1d(k) = 4.99E-6 if (rs(k).le.R1) CYCLE tc0 = MIN(-0.1, t1d(k)-273.15) smob = rs(k)*oams @@ -4796,7 +4906,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) smoc = a_ * smo2**b_ - re_qs1d(k) = MAX(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) + re_qs1d(k) = MAX(5.01E-6, MIN(0.5*(smoc/smob), 999.E-6)) enddo endif @@ -4897,6 +5007,14 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & !..Calculate y-intercept, slope, and useful moments for snow. !+---+-----------------------------------------------------------------+ do k = kts, kte + smo2(k) = 0. + smob(k) = 0. + smoc(k) = 0. + smoz(k) = 0. + enddo + if (ANY(L_qs .eqv. .true.)) then + do k = kts, kte + if (.not. L_qs(k)) CYCLE tc0 = MIN(-0.1, temp(k)-273.15) smob(k) = rs(k)*oams @@ -4945,11 +5063,13 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(3)*cse(3)*cse(3) smoz(k) = a_ * smo2(k)**b_ enddo + endif !+---+-----------------------------------------------------------------+ !..Calculate y-intercept, slope values for graupel. !+---+-----------------------------------------------------------------+ + if (ANY(L_qg .eqv. .true.)) then N0_min = gonv_max k_0 = kts do k = kte, kts, -1 @@ -4972,6 +5092,7 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & ilamg(k) = 1./lamg N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2) enddo + endif !+---+-----------------------------------------------------------------+ !..Locate K-level of start of melting (k_0 is level above). diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_aerosols.F b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_aerosols.F new file mode 100644 index 0000000000..48fb6fb641 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_thompson_aerosols.F @@ -0,0 +1,214 @@ +!================================================================================================================= +!module_mp_thompson_aerosols includes subroutine gt_aod. gt_aod is called from subroutine radiation_sw_from_MPAS +!in mpas_atmphys_driver_radiation_sw.F. gt_aod calculates the 550 nm aerosol optical depth of "water-friendly" +!and "ice-friendly" aerosols from the Thompson cloud microphysics scheme. gt_aod was copied from WRF-4.0.2 (see +!module_radiation_driver.F). +!Laura D. Fowler (laura@ucar.edu) / 2019-01-13. + + module module_mp_thompson_aerosols + use mpas_atmphys_functions,only: rslf + use mpas_atmphys_utilities, only: physics_error_fatal,physics_message +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) + + implicit none + private + public:: gt_aod + + + contains + + +!================================================================================================================= + SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d, & + & ims,ime, jms,jme, kms,kme, its,ite, jts,jte, kts,kte) + +! USE module_mp_thompson, only: RSLF + +! IMPLICIT NONE + + INTEGER, INTENT(IN):: ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: & + & t_phy,p_phy, DZ8W, & + & qvapor, nifa, nwfa + REAL,DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT):: taod5503d + + !..Local variables. + + REAL, DIMENSION(its:ite,kts:kte,jts:jte):: AOD_wfa, AOD_ifa + REAL:: RH, a_RH,b_RH, rh_d,rh_f, rhoa,qvsat, unit_bext1,unit_bext3 + REAL:: ntemp + INTEGER :: i, k, j, RH_idx, RH_idx1, RH_idx2, t_idx + INTEGER, PARAMETER:: rind=8 + REAL, DIMENSION(rind), PARAMETER:: rh_arr = & + & (/10., 60., 70., 80., 85., 90., 95., 99.8/) + REAL, DIMENSION(rind,4,2) :: lookup_tabl ! RH, temp, water-friendly, ice-friendly + + lookup_tabl(1,1,1) = 5.73936E-15 + lookup_tabl(1,1,2) = 2.63577E-12 + lookup_tabl(1,2,1) = 5.73936E-15 + lookup_tabl(1,2,2) = 2.63577E-12 + lookup_tabl(1,3,1) = 5.73936E-15 + lookup_tabl(1,3,2) = 2.63577E-12 + lookup_tabl(1,4,1) = 5.73936E-15 + lookup_tabl(1,4,2) = 2.63577E-12 + + lookup_tabl(2,1,1) = 6.93515E-15 + lookup_tabl(2,1,2) = 2.72095E-12 + lookup_tabl(2,2,1) = 6.93168E-15 + lookup_tabl(2,2,2) = 2.72092E-12 + lookup_tabl(2,3,1) = 6.92570E-15 + lookup_tabl(2,3,2) = 2.72091E-12 + lookup_tabl(2,4,1) = 6.91833E-15 + lookup_tabl(2,4,2) = 2.72087E-12 + + lookup_tabl(3,1,1) = 7.24707E-15 + lookup_tabl(3,1,2) = 2.77219E-12 + lookup_tabl(3,2,1) = 7.23809E-15 + lookup_tabl(3,2,2) = 2.77222E-12 + lookup_tabl(3,3,1) = 7.23108E-15 + lookup_tabl(3,3,2) = 2.77201E-12 + lookup_tabl(3,4,1) = 7.21800E-15 + lookup_tabl(3,4,2) = 2.77111E-12 + + lookup_tabl(4,1,1) = 8.95130E-15 + lookup_tabl(4,1,2) = 2.87263E-12 + lookup_tabl(4,2,1) = 9.01582E-15 + lookup_tabl(4,2,2) = 2.87252E-12 + lookup_tabl(4,3,1) = 9.13216E-15 + lookup_tabl(4,3,2) = 2.87241E-12 + lookup_tabl(4,4,1) = 9.16219E-15 + lookup_tabl(4,4,2) = 2.87211E-12 + + lookup_tabl(5,1,1) = 1.06695E-14 + lookup_tabl(5,1,2) = 2.96752E-12 + lookup_tabl(5,2,1) = 1.06370E-14 + lookup_tabl(5,2,2) = 2.96726E-12 + lookup_tabl(5,3,1) = 1.05999E-14 + lookup_tabl(5,3,2) = 2.96702E-12 + lookup_tabl(5,4,1) = 1.05443E-14 + lookup_tabl(5,4,2) = 2.96603E-12 + + lookup_tabl(6,1,1) = 1.37908E-14 + lookup_tabl(6,1,2) = 3.15081E-12 + lookup_tabl(6,2,1) = 1.37172E-14 + lookup_tabl(6,2,2) = 3.15020E-12 + lookup_tabl(6,3,1) = 1.36362E-14 + lookup_tabl(6,3,2) = 3.14927E-12 + lookup_tabl(6,4,1) = 1.35287E-14 + lookup_tabl(6,4,2) = 3.14817E-12 + + lookup_tabl(7,1,1) = 2.26019E-14 + lookup_tabl(7,1,2) = 3.66798E-12 + lookup_tabl(7,2,1) = 2.24435E-14 + lookup_tabl(7,2,2) = 3.66540E-12 + lookup_tabl(7,3,1) = 2.23254E-14 + lookup_tabl(7,3,2) = 3.66173E-12 + lookup_tabl(7,4,1) = 2.20496E-14 + lookup_tabl(7,4,2) = 3.65796E-12 + + lookup_tabl(8,1,1) = 4.41983E-13 + lookup_tabl(8,1,2) = 7.50091E-11 + lookup_tabl(8,2,1) = 3.93335E-13 + lookup_tabl(8,2,2) = 6.79097E-11 + lookup_tabl(8,3,1) = 3.45569E-13 + lookup_tabl(8,3,2) = 6.07845E-11 + lookup_tabl(8,4,1) = 2.96971E-13 + lookup_tabl(8,4,2) = 5.36085E-11 + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + AOD_wfa(i,k,j) = 0. + AOD_ifa(i,k,j) = 0. + END DO + END DO + END DO + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + rhoa = p_phy(i,k,j)/(287.*t_phy(i,k,j)) + t_idx = MAX(1, MIN(nint(10.999-0.0333*t_phy(i,k,j)),4)) + qvsat = rslf(p_phy(i,k,j),t_phy(i,k,j)) + RH = MIN(98., MAX(10.1, qvapor(i,k,j)/qvsat*100.)) + + !..Get the index for the RH array element + + if (RH .lt. 60) then + RH_idx1 = 1 + RH_idx2 = 2 + elseif (RH .ge. 60 .AND. RH.lt.80) then + a_RH = 0.1 + b_RH = -4 + RH_idx = nint(a_RH*RH+b_RH) + rh_d = rh-rh_arr(rh_idx) + if (rh_d .lt. 0) then + RH_idx1 = RH_idx-1 + RH_idx2 = RH_idx + else + RH_idx1 = RH_idx + RH_idx2 = RH_idx+1 + if (RH_idx2.gt.rind) then + RH_idx2 = rind + RH_idx1 = rind-1 + endif + endif + else + a_RH = 0.2 + b_RH = -12. + RH_idx = MIN(rind, nint(a_RH*RH+b_RH)) + rh_d = rh-rh_arr(rh_idx) + if (rh_d .lt. 0) then + RH_idx1 = RH_idx-1 + RH_idx2 = RH_idx + else + RH_idx1 = RH_idx + RH_idx2 = RH_idx+1 + if (RH_idx2.gt.rind) then + RH_idx2 = rind + RH_idx1 = rind-1 + endif + endif + endif + + !..RH fraction to be used + + rh_f = MAX(0., MIN(1.0, (rh/(100-rh)-rh_arr(rh_idx1) & + & /(100-rh_arr(rh_idx1))) & + & /(rh_arr(rh_idx2)/(100-rh_arr(rh_idx2)) & + & -rh_arr(rh_idx1)/(100-rh_arr(rh_idx1))) )) + + + unit_bext1 = lookup_tabl(RH_idx1,t_idx,1) & + & + (lookup_tabl(RH_idx2,t_idx,1) & + & - lookup_tabl(RH_idx1,t_idx,1))*rh_f + unit_bext3 = lookup_tabl(RH_idx1,t_idx,2) & + & + (lookup_tabl(RH_idx2,t_idx,2) & + & - lookup_tabl(RH_idx1,t_idx,2))*rh_f + + ntemp = MAX(1., MIN(99999.E6, nwfa(i,k,j))) + AOD_wfa(i,k,j) = unit_bext1*ntemp*dz8w(i,k,j)*rhoa + + ntemp = MAX(0.01, MIN(9999.E6, nifa(i,k,j))) + AOD_ifa(i,k,j) = unit_bext3*ntemp*dz8w(i,k,j)*rhoa + + END DO + END DO + END DO + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + taod5503d(i,k,j) = aod_wfa(i,k,j) + aod_ifa(i,k,j) + END DO + END DO + END DO + + END SUBROUTINE gt_aod + +!================================================================================================================= + end module module_mp_thompson_aerosols +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F b/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F index b95266c7e5..07c0de6b38 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F +++ b/src/core_atmosphere/physics/physics_wrf/module_mp_wsm6.F @@ -1,2636 +1,239 @@ -!================================================================================================================= -!module_mp_wsm6.F was originally copied from ./phys/module_mp_wsm6.F from WRF version 3.8.1. -!Laura D. Fowler (laura@ucar.edu) / 2016-09-23. - -!modifications to sourcecode for MPAS: -! * replaced the line "#if ( RWORDSIZE == 4 )" with "#ifdef SINGLE_PRECISION". -! * commented out the lines: -! USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm -! USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep -! * changed the declaration of refl_10cm to optional since subroutine refl10cm_wsm6 is called -! in mpas_atmphys_driver_microphysics.F. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-17. - -!================================================================================================================= -#ifdef SINGLE_PRECISION -# define VREC vsrec -# define VSQRT vssqrt -#else -# define VREC vrec -# define VSQRT vsqrt -#endif - -MODULE module_mp_wsm6 -! -! USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm -! USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep - USE module_mp_radar -! - REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops - REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain -! REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain - REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m - REAL, PARAMETER, PRIVATE :: peaut = .55 ! collection efficiency - REAL, PARAMETER, PRIVATE :: xncr = 3.e8 ! maritime cloud in contrast to 3.e8 in tc80 - REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 - REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow -! REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel ! set later with hail_opt -! REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel ! set later with hail_opt - REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) - REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain - REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow -! REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter - REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow - REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s - REAL, PARAMETER, PRIVATE :: pfrz1 = 100. ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: pfrz2 = 0.66 ! constant in Biggs freezing - REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg - REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency - REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow - REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur - REAL, SAVE :: & - qc0, qck1, pidnc, & - bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & - g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & - bvtr6,g6pbr, & - precr1,precr2,roqimax,bvts1, & - bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & - n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init - g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & - pidn0s,xlv1,pacrc,pi, & - bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & - g3pbg,g4pbg,g5pbgo2,pvtg,pacrg, & - precg1,precg2,pidn0g, & - rslopermax,rslopesmax,rslopegmax, & - rsloperbmax,rslopesbmax,rslopegbmax, & - rsloper2max,rslopes2max,rslopeg2max, & - rsloper3max,rslopes3max,rslopeg3max -CONTAINS -!=================================================================== -! - SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & - ,den, pii, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,rain, rainncv & - ,snow, snowncv & - ,sr & - ,refl_10cm, diagflag, do_radar_ref & - ,graupel, graupelncv & - ,has_reqc, has_reqi, has_reqs & ! for radiation - ,re_cloud, re_ice, re_snow & ! for radiation - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - 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) :: & - th, & - q, & - qc, & - qi, & - qr, & - qs, & - qg - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: & - den, & - pii, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - rd, & - rv, & - t0c, & - den0, & - cpd, & - cpv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime , jms:jme ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr -! for radiation connecting - INTEGER, INTENT(IN):: & - has_reqc, & - has_reqi, & - has_reqs - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - INTENT(INOUT):: & - re_cloud, & - re_ice, & - re_snow -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT), OPTIONAL:: & ! GT - refl_10cm -!+---+-----------------------------------------------------------------+ - - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte ) :: t - REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci - REAL, DIMENSION( its:ite , kts:kte, 3 ) :: qrs - INTEGER :: i,j,k - -!+---+-----------------------------------------------------------------+ - REAL, DIMENSION(kts:kte):: qv1d, t1d, p1d, qr1d, qs1d, qg1d, dBZ - LOGICAL, OPTIONAL, INTENT(IN) :: diagflag - INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref -!+---+-----------------------------------------------------------------+ -! to calculate effective radius for radiation - REAL, DIMENSION( kts:kte ) :: den1d - REAL, DIMENSION( kts:kte ) :: qc1d - REAL, DIMENSION( kts:kte ) :: qi1d - REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs - - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - t(i,k)=th(i,k,j)*pii(i,k,j) - qci(i,k,1) = qc(i,k,j) - qci(i,k,2) = qi(i,k,j) - qrs(i,k,1) = qr(i,k,j) - qrs(i,k,2) = qs(i,k,j) - qrs(i,k,3) = qg(i,k,j) - ENDDO - ENDDO - ! Sending array starting locations of optional variables may cause - ! troubles, so we explicitly change the call. - CALL wsm62D(t, q(ims,kms,j), qci, qrs & - ,den(ims,kms,j) & - ,p(ims,kms,j), delz(ims,kms,j) & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,j & - ,rain(ims,j),rainncv(ims,j) & - ,sr(ims,j) & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & - ) - DO K=kts,kte - DO I=its,ite - th(i,k,j)=t(i,k)/pii(i,k,j) - qc(i,k,j) = qci(i,k,1) - qi(i,k,j) = qci(i,k,2) - qr(i,k,j) = qrs(i,k,1) - qs(i,k,j) = qrs(i,k,2) - qg(i,k,j) = qrs(i,k,3) - ENDDO - ENDDO - -!+---+-----------------------------------------------------------------+ - IF ( PRESENT (diagflag) ) THEN - if (diagflag .and. do_radar_ref == 1) then - DO I=its,ite - DO K=kts,kte - t1d(k)=th(i,k,j)*pii(i,k,j) - p1d(k)=p(i,k,j) - qv1d(k)=q(i,k,j) - qr1d(k)=qr(i,k,j) - qs1d(k)=qs(i,k,j) - qg1d(k)=qg(i,k,j) - ENDDO - call refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, i, j) - do k = kts, kte - refl_10cm(i,k,j) = MAX(-35., dBZ(k)) - enddo - ENDDO - endif - ENDIF - - if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then - do i=its,ite - do k=kts,kte - re_qc(k) = 2.51E-6 - re_qi(k) = 10.01E-6 - re_qs(k) = 25.E-6 - - t1d(k) = th(i,k,j)*pii(i,k,j) - den1d(k)= den(i,k,j) - qc1d(k) = qc(i,k,j) - qi1d(k) = qi(i,k,j) - qs1d(k) = qs(i,k,j) - enddo - call effectRad_wsm6(t1d, qc1d, qi1d, qs1d, den1d, & - qmin, t0c, re_qc, re_qi, re_qs, & - kts, kte, i, j) - do k=kts,kte - re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) - re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) - re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) - enddo - enddo - endif ! has_reqc, etc... -!+---+-----------------------------------------------------------------+ - - ENDDO - END SUBROUTINE wsm6 -!=================================================================== -! - SUBROUTINE wsm62D(t, q & - ,qci, qrs, den, p, delz & - ,delt,g, cpd, cpv, rd, rv, t0c & - ,ep1, ep2, qmin & - ,XLS, XLV0, XLF0, den0, denr & - ,cliq,cice,psat & - ,lat & - ,rain,rainncv & - ,sr & - ,ids,ide, jds,jde, kds,kde & - ,ims,ime, jms,jme, kms,kme & - ,its,ite, jts,jte, kts,kte & - ,snow,snowncv & - ,graupel,graupelncv & - ) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! -! This code is a 6-class GRAUPEL phase microphyiscs scheme (WSM6) of the -! Single-Moment MicroPhyiscs (WSMMP). The WSMMP assumes that ice nuclei -! number concentration is a function of temperature, and seperate assumption -! is developed, in which ice crystal number concentration is a function -! of ice amount. A theoretical background of the ice-microphysics and related -! processes in the WSMMPs are described in Hong et al. (2004). -! All production terms in the WSM6 scheme are described in Hong and Lim (2006). -! All units are in m.k.s. and source/sink terms in kgkg-1s-1. -! -! WSM6 cloud scheme -! -! Coded by Song-You Hong and Jeong-Ock Jade Lim (Yonsei Univ.) -! Summer 2003 -! -! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) -! Summer 2004 -! -! further modifications : -! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 -! ==> higher accuracy and efficient at lower resolutions -! reflectivity computation from greg thompson, lim, jun 2011 -! ==> only diagnostic, but with removal of too large drops -! add hail option from afwa, aug 2014 -! ==> switch graupel or hail by changing no, den, fall vel. -! effective radius of hydrometeors, bae from kiaps, jan 2015 -! ==> consistency in solar insolation of rrtmg radiation -! bug fix in melting terms, bae from kiaps, nov 2015 -! ==> density of air is divided, which has not been -! -! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. -! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. -! Dudhia, Hong and Lim (DHL, 2008) J. Meteor. Soc. Japan -! Lin, Farley, Orville (LFO, 1983) J. Appl. Meteor. -! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. -! Rutledge, Hobbs (RH84, 1984) J. Atmos. Sci. -! Juang and Hong (JH, 2010) Mon. Wea. Rev. -! - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & - ims,ime, jms,jme, kms,kme , & - its,ite, jts,jte, kts,kte, & - lat - REAL, DIMENSION( its:ite , kts:kte ), & - INTENT(INOUT) :: & - t - REAL, DIMENSION( its:ite , kts:kte, 2 ), & - INTENT(INOUT) :: & - qci - REAL, DIMENSION( its:ite , kts:kte, 3 ), & - INTENT(INOUT) :: & - qrs - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(INOUT) :: & - q - REAL, DIMENSION( ims:ime , kms:kme ), & - INTENT(IN ) :: & - den, & - p, & - delz - REAL, INTENT(IN ) :: delt, & - g, & - cpd, & - cpv, & - t0c, & - den0, & - rd, & - rv, & - ep1, & - ep2, & - qmin, & - XLS, & - XLV0, & - XLF0, & - cliq, & - cice, & - psat, & - denr - REAL, DIMENSION( ims:ime ), & - INTENT(INOUT) :: rain, & - rainncv, & - sr - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: snow, & - snowncv - REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & - INTENT(INOUT) :: graupel, & - graupelncv -! LOCAL VAR - REAL, DIMENSION( its:ite , kts:kte , 3) :: & - rh, & - qs, & - rslope, & - rslope2, & - rslope3, & - rslopeb, & - qrs_tmp, & - falk, & - fall, & - work1 - REAL, DIMENSION( its:ite , kts:kte ) :: & - fallc, & - falkc, & - work1c, & - work2c, & - workr, & - worka - REAL, DIMENSION( its:ite , kts:kte ) :: & - den_tmp, & - delz_tmp - REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, & - pidep, & - pcond, & - prevp, & - psevp, & - pgevp, & - psdep, & - pgdep, & - praut, & - psaut, & - pgaut, & - piacr, & - pracw, & - praci, & - pracs, & - psacw, & - psaci, & - psacr, & - pgacw, & - pgaci, & - pgacr, & - pgacs, & - paacw, & - psmlt, & - pgmlt, & - pseml, & - pgeml - REAL, DIMENSION( its:ite , kts:kte ) :: & - qsum, & - xl, & - cpm, & - work2, & - denfac, & - xni, & - denqrs1, & - denqrs2, & - denqrs3, & - denqci, & - n0sfac - REAL, DIMENSION( its:ite ) :: delqrs1, & - delqrs2, & - delqrs3, & - delqi - REAL, DIMENSION( its:ite ) :: tstepsnow, & - tstepgraup - INTEGER, DIMENSION( its:ite ) :: mstep, & - numdt - LOGICAL, DIMENSION( its:ite ) :: flgcld - REAL :: & - cpmcal, xlcal, diffus, & - viscos, xka, venfac, conden, diffac, & - x, y, z, a, b, c, d, e, & - qdt, holdrr, holdrs, holdrg, supcol, supcolt, pvt, & - coeres, supsat, dtcld, xmi, eacrs, satdt, & - qimax, diameter, xni0, roqi0, & - fallsum, fallsum_qsi, fallsum_qg, & - vt2i,vt2r,vt2s,vt2g,acrfac,egs,egi, & - xlwork2, factor, source, value, & - xlf, pfrzdtc, pfrzdtr, supice, alpha2, delta2, delta3 - REAL :: vt2ave - REAL :: holdc, holdci - INTEGER :: i, j, k, mstepmax, & - iprt, latd, lond, loop, loops, ifsat, n, idim, kdim -! Temporaries used for inlining fpvs function - REAL :: dldti, xb, xai, tr, xbi, xa, hvap, cvap, hsub, dldt, ttp -! variables for optimization - REAL, DIMENSION( its:ite ) :: tvec1 - REAL :: temp -! -!================================================================= -! compute internal functions -! - cpmcal(x) = cpd*(1.-max(x,qmin))+max(x,qmin)*cpv - xlcal(x) = xlv0-xlv1*(x-t0c) -!---------------------------------------------------------------- -! diffus: diffusion coefficient of the water vapor -! viscos: kinematic viscosity(m2s-1) -! Optimizatin : A**B => exp(log(A)*(B)) -! - diffus(x,y) = 8.794e-5 * exp(log(x)*(1.81)) / y ! 8.794e-5*x**1.81/y - viscos(x,y) = 1.496e-6 * (x*sqrt(x)) /(x+120.)/y ! 1.496e-6*x**1.5/(x+120.)/y - xka(x,y) = 1.414e3*viscos(x,y)*y - diffac(a,b,c,d,e) = d*a*a/(xka(c,d)*rv*c*c)+1./(e*diffus(c,b)) - venfac(a,b,c) = exp(log((viscos(b,c)/diffus(b,a)))*((.3333333))) & - /sqrt(viscos(b,c))*sqrt(sqrt(den0/c)) - conden(a,b,c,d,e) = (max(b,qmin)-c)/(1.+d*d/(rv*e)*c/(a*a)) -! -! - idim = ite-its+1 - kdim = kte-kts+1 -! -!---------------------------------------------------------------- -! paddint 0 for negative values generated by dynamics -! - do k = kts, kte - do i = its, ite - qci(i,k,1) = max(qci(i,k,1),0.0) - qrs(i,k,1) = max(qrs(i,k,1),0.0) - qci(i,k,2) = max(qci(i,k,2),0.0) - qrs(i,k,2) = max(qrs(i,k,2),0.0) - qrs(i,k,3) = max(qrs(i,k,3),0.0) - enddo - enddo -! -!---------------------------------------------------------------- -! latent heat for phase changes and heat capacity. neglect the -! changes during microphysical process calculation -! emanuel(1994) -! - do k = kts, kte - do i = its, ite - cpm(i,k) = cpmcal(q(i,k)) - xl(i,k) = xlcal(t(i,k)) - enddo - enddo - do k = kts, kte - do i = its, ite - delz_tmp(i,k) = delz(i,k) - den_tmp(i,k) = den(i,k) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the surface rain, snow, graupel -! - do i = its, ite - rainncv(i) = 0. - if(PRESENT (snowncv) .AND. PRESENT (snow)) snowncv(i,lat) = 0. - if(PRESENT (graupelncv) .AND. PRESENT (graupel)) graupelncv(i,lat) = 0. - sr(i) = 0. -! new local array to catch step snow and graupel - tstepsnow(i) = 0. - tstepgraup(i) = 0. - enddo -! -!---------------------------------------------------------------- -! compute the minor time steps. -! - loops = max(nint(delt/dtcldcr),1) - dtcld = delt/loops - if(delt.le.dtcldcr) dtcld = delt -! - do loop = 1,loops -! -!---------------------------------------------------------------- -! initialize the large scale variables -! - do i = its, ite - mstep(i) = 1 - flgcld(i) = .true. - enddo -! -! do k = kts, kte -! do i = its, ite -! denfac(i,k) = sqrt(den0/den(i,k)) -! enddo -! enddo - do k = kts, kte - CALL VREC( tvec1(its), den(its,k), ite-its+1) - do i = its, ite - tvec1(i) = tvec1(i)*den0 - enddo - CALL VSQRT( denfac(its,k), tvec1(its), ite-its+1) - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - rh(i,k,1) = max(q(i,k) / qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - rh(i,k,2) = max(q(i,k) / qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! initialize the variables for microphysical physics -! -! - do k = kts, kte - do i = its, ite - prevp(i,k) = 0. - psdep(i,k) = 0. - pgdep(i,k) = 0. - praut(i,k) = 0. - psaut(i,k) = 0. - pgaut(i,k) = 0. - pracw(i,k) = 0. - praci(i,k) = 0. - piacr(i,k) = 0. - psaci(i,k) = 0. - psacw(i,k) = 0. - pracs(i,k) = 0. - psacr(i,k) = 0. - pgacw(i,k) = 0. - paacw(i,k) = 0. - pgaci(i,k) = 0. - pgacr(i,k) = 0. - pgacs(i,k) = 0. - pigen(i,k) = 0. - pidep(i,k) = 0. - pcond(i,k) = 0. - psmlt(i,k) = 0. - pgmlt(i,k) = 0. - pseml(i,k) = 0. - pgeml(i,k) = 0. - psevp(i,k) = 0. - pgevp(i,k) = 0. - falk(i,k,1) = 0. - falk(i,k,2) = 0. - falk(i,k,3) = 0. - fall(i,k,1) = 0. - fall(i,k,2) = 0. - fall(i,k,3) = 0. - fallc(i,k) = 0. - falkc(i,k) = 0. - xni(i,k) = 1.e3 - enddo - enddo -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- - do k = kts, kte - do i = its, ite - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - enddo - enddo -! -!---------------------------------------------------------------- -! compute the fallout term: -! first, vertical terminal velosity for minor loops -!---------------------------------------------------------------- - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - workr(i,k) = work1(i,k,1) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - IF ( qsum(i,k) .gt. 1.e-15 ) THEN - worka(i,k) = (work1(i,k,2)*qrs(i,k,2) + work1(i,k,3)*qrs(i,k,3)) & - /qsum(i,k) - ELSE - worka(i,k) = 0. - ENDIF - denqrs1(i,k) = den(i,k)*qrs(i,k,1) - denqrs2(i,k) = den(i,k)*qrs(i,k,2) - denqrs3(i,k) = den(i,k)*qrs(i,k,3) - if(qrs(i,k,1).le.0.0) workr(i,k) = 0.0 - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,workr,denqrs1, & - delqrs1,dtcld,1,1) - call nislfv_rain_plm6(idim,kdim,den_tmp,denfac,t,delz_tmp,worka, & - denqrs2,denqrs3,delqrs2,delqrs3,dtcld,1,1) - do k = kts, kte - do i = its, ite - qrs(i,k,1) = max(denqrs1(i,k)/den(i,k),0.) - qrs(i,k,2) = max(denqrs2(i,k)/den(i,k),0.) - qrs(i,k,3) = max(denqrs3(i,k)/den(i,k),0.) - fall(i,k,1) = denqrs1(i,k)*workr(i,k)/delz(i,k) - fall(i,k,2) = denqrs2(i,k)*worka(i,k)/delz(i,k) - fall(i,k,3) = denqrs3(i,k)*worka(i,k)/delz(i,k) - enddo - enddo - do i = its, ite - fall(i,1,1) = delqrs1(i)/delz(i,1)/dtcld - fall(i,1,2) = delqrs2(i)/delz(i,1)/dtcld - fall(i,1,3) = delqrs3(i)/delz(i,1)/dtcld - enddo - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -! - do k = kte, kts, -1 - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(t(i,k).gt.t0c) then -!--------------------------------------------------------------- -! psmlt: melting of snow [HL A33] [RH83 A25] -! (T>T0: S->R) -!--------------------------------------------------------------- - xlf = xlf0 - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - if(qrs(i,k,2).gt.0.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & - *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres)/den(i,k) - psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,2)/mstep(i)),0.) - qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - psmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*psmlt(i,k) - endif -!--------------------------------------------------------------- -! pgmlt: melting of graupel [HL A23] [LFO 47] -! (T>T0: G->R) -!--------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & - *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/den(i,k) - pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & - -qrs(i,k,3)/mstep(i)),0.) - qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) - qrs(i,k,1) = qrs(i,k,1) - pgmlt(i,k) - t(i,k) = t(i,k) + xlf/cpm(i,k)*pgmlt(i,k) - endif - endif - enddo - enddo -!--------------------------------------------------------------- -! Vice [ms-1] : fallout of ice crystal [HDC 5a] -!--------------------------------------------------------------- - do k = kte, kts, -1 - do i = its, ite - if(qci(i,k,2).le.0.) then - work1c(i,k) = 0. - else - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = max(min(dicon * sqrt(xmi),dimax), 1.e-25) - work1c(i,k) = 1.49e4*exp(log(diameter)*(1.31)) - endif - enddo - enddo -! -! forward semi-laglangian scheme (JH), PCM (piecewise constant), (linear) -! - do k = kte, kts, -1 - do i = its, ite - denqci(i,k) = den(i,k)*qci(i,k,2) - enddo - enddo - call nislfv_rain_plm(idim,kdim,den_tmp,denfac,t,delz_tmp,work1c,denqci, & - delqi,dtcld,1,0) - do k = kts, kte - do i = its, ite - qci(i,k,2) = max(denqci(i,k)/den(i,k),0.) - enddo - enddo - do i = its, ite - fallc(i,1) = delqi(i)/delz(i,1)/dtcld - enddo -! -!---------------------------------------------------------------- -! rain (unit is mm/sec;kgm-2s-1: /1000*delt ===> m)==> mm for wrf -! - do i = its, ite - fallsum = fall(i,kts,1)+fall(i,kts,2)+fall(i,kts,3)+fallc(i,kts) - fallsum_qsi = fall(i,kts,2)+fallc(i,kts) - fallsum_qg = fall(i,kts,3) - if(fallsum.gt.0.) then - rainncv(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rainncv(i) - rain(i) = fallsum*delz(i,kts)/denr*dtcld*1000. + rain(i) - endif - if(fallsum_qsi.gt.0.) then - tstepsnow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - +tstepsnow(i) - IF ( PRESENT (snowncv) .AND. PRESENT (snow)) THEN - snowncv(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. & - +snowncv(i,lat) - snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat) - ENDIF - endif - if(fallsum_qg.gt.0.) then - tstepgraup(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - +tstepgraup(i) - IF ( PRESENT (graupelncv) .AND. PRESENT (graupel)) THEN - graupelncv(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. & - + graupelncv(i,lat) - graupel(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i,lat) - ENDIF - endif - IF ( PRESENT (snowncv)) THEN - if(fallsum.gt.0.)sr(i)=(snowncv(i,lat) + graupelncv(i,lat))/(rainncv(i)+1.e-12) - ELSE - if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12) - ENDIF - enddo -! -!--------------------------------------------------------------- -! pimlt: instantaneous melting of cloud ice [HL A47] [RH83 A28] -! (T>T0: I->C) -!--------------------------------------------------------------- - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - xlf = xls-xl(i,k) - if(supcol.lt.0.) xlf = xlf0 - if(supcol.lt.0.and.qci(i,k,2).gt.0.) then - qci(i,k,1) = qci(i,k,1) + qci(i,k,2) - t(i,k) = t(i,k) - xlf/cpm(i,k)*qci(i,k,2) - qci(i,k,2) = 0. - endif -!--------------------------------------------------------------- -! pihmf: homogeneous freezing of cloud water below -40c [HL A45] -! (T<-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.40..and.qci(i,k,1).gt.0.) then - qci(i,k,2) = qci(i,k,2) + qci(i,k,1) - t(i,k) = t(i,k) + xlf/cpm(i,k)*qci(i,k,1) - qci(i,k,1) = 0. - endif -!--------------------------------------------------------------- -! pihtf: heterogeneous freezing of cloud water [HL A44] -! (T0>T>-40C: C->I) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qci(i,k,1).gt.qmin) then -! pfrzdtc = min(pfrz1*(exp(pfrz2*supcol)-1.) & -! *den(i,k)/denr/xncr*qci(i,k,1)**2*dtcld,qci(i,k,1)) - supcolt=min(supcol,50.) - pfrzdtc = min(pfrz1*(exp(pfrz2*supcolt)-1.) & - *den(i,k)/denr/xncr*qci(i,k,1)*qci(i,k,1)*dtcld,qci(i,k,1)) - qci(i,k,2) = qci(i,k,2) + pfrzdtc - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtc - qci(i,k,1) = qci(i,k,1)-pfrzdtc - endif -!--------------------------------------------------------------- -! pgfrz: freezing of rain water [HL A20] [LFO 45] -! (TG) -!--------------------------------------------------------------- - if(supcol.gt.0..and.qrs(i,k,1).gt.0.) then -! pfrzdtr = min(20.*pi**2*pfrz1*n0r*denr/den(i,k) & -! *(exp(pfrz2*supcol)-1.)*rslope3(i,k,1)**2 & -! *rslope(i,k,1)*dtcld,qrs(i,k,1)) - temp = rslope3(i,k,1) - temp = temp*temp*rslope(i,k,1) - supcolt=min(supcol,50.) - pfrzdtr = min(20.*(pi*pi)*pfrz1*n0r*denr/den(i,k) & - *(exp(pfrz2*supcolt)-1.)*temp*dtcld, & - qrs(i,k,1)) - qrs(i,k,3) = qrs(i,k,3) + pfrzdtr - t(i,k) = t(i,k) + xlf/cpm(i,k)*pfrzdtr - qrs(i,k,1) = qrs(i,k,1)-pfrzdtr - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! update the slope parameters for microphysics computation -! - do k = kts, kte - do i = its, ite - qrs_tmp(i,k,1) = qrs(i,k,1) - qrs_tmp(i,k,2) = qrs(i,k,2) - qrs_tmp(i,k,3) = qrs(i,k,3) - enddo - enddo - call slope_wsm6(qrs_tmp,den_tmp,denfac,t,rslope,rslopeb,rslope2,rslope3, & - work1,its,ite,kts,kte) -!------------------------------------------------------------------ -! work1: the thermodynamic term in the denominator associated with -! heat conduction and vapor diffusion -! (ry88, y93, h85) -! work2: parameter associated with the ventilation effects(y93) -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = diffac(xl(i,k),p(i,k),t(i,k),den(i,k),qs(i,k,1)) - work1(i,k,2) = diffac(xls,p(i,k),t(i,k),den(i,k),qs(i,k,2)) - work2(i,k) = venfac(p(i,k),t(i,k),den(i,k)) - enddo - enddo -! -!=============================================================== -! -! warm rain processes -! -! - follows the processes in RH83 and LFO except for autoconcersion -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supsat = max(q(i,k),qmin)-qs(i,k,1) - satdt = supsat/dtcld -!--------------------------------------------------------------- -! praut: auto conversion rate from cloud to rain [HDC 16] -! (C->R) -!--------------------------------------------------------------- - if(qci(i,k,1).gt.qc0) then - praut(i,k) = qck1*qci(i,k,1)**(7./3.) - praut(i,k) = min(praut(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! pracw: accretion of cloud water by rain [HL A40] [LFO 51] -! (C->R) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pracw(i,k) = min(pacrr*rslope3(i,k,1)*rslopeb(i,k,1) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!--------------------------------------------------------------- -! prevp: evaporation/condensation rate of rain [HDC 14] -! (V->R or R->V) -!--------------------------------------------------------------- - if(qrs(i,k,1).gt.0.) then - coeres = rslope2(i,k,1)*sqrt(rslope(i,k,1)*rslopeb(i,k,1)) - prevp(i,k) = (rh(i,k,1)-1.)*(precr1*rslope2(i,k,1) & - +precr2*work2(i,k)*coeres)/work1(i,k,1) - if(prevp(i,k).lt.0.) then - prevp(i,k) = max(prevp(i,k),-qrs(i,k,1)/dtcld) - prevp(i,k) = max(prevp(i,k),satdt/2) - else - prevp(i,k) = min(prevp(i,k),satdt/2) - endif - endif - enddo - enddo -! -!=============================================================== -! -! cold rain processes -! -! - follows the revised ice microphysics processes in HDC -! - the processes same as in RH83 and RH84 and LFO behave -! following ice crystal hapits defined in HDC, inclduing -! intercept parameter for snow (n0s), ice crystal number -! concentration (ni), ice nuclei number concentration -! (n0i), ice diameter (d) -! -!=============================================================== -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - supsat = max(q(i,k),qmin)-qs(i,k,2) - satdt = supsat/dtcld - ifsat = 0 -!------------------------------------------------------------- -! Ni: ice crystal number concentraiton [HDC 5c] -!------------------------------------------------------------- -! xni(i,k) = min(max(5.38e7*(den(i,k) & -! *max(qci(i,k,2),qmin))**0.75,1.e3),1.e6) - temp = (den(i,k)*max(qci(i,k,2),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - xni(i,k) = min(max(5.38e7*temp,1.e3),1.e6) - eacrs = exp(0.07*(-supcol)) -! - xmi = den(i,k)*qci(i,k,2)/xni(i,k) - diameter = min(dicon * sqrt(xmi),dimax) - vt2i = 1.49e4*diameter**1.31 - vt2r=pvtr*rslopeb(i,k,1)*denfac(i,k) - vt2s=pvts*rslopeb(i,k,2)*denfac(i,k) - vt2g=pvtg*rslopeb(i,k,3)*denfac(i,k) - qsum(i,k) = max( (qrs(i,k,2)+qrs(i,k,3)), 1.E-15) - if(qsum(i,k) .gt. 1.e-15) then - vt2ave=(vt2s*qrs(i,k,2)+vt2g*qrs(i,k,3))/(qsum(i,k)) - else - vt2ave=0. - endif - if(supcol.gt.0.and.qci(i,k,2).gt.qmin) then - if(qrs(i,k,1).gt.qcrmin) then -!------------------------------------------------------------- -! praci: Accretion of cloud ice by rain [HL A15] [LFO 25] -! (TR) -!------------------------------------------------------------- - acrfac = 2.*rslope3(i,k,1)+2.*diameter*rslope2(i,k,1) & - +diameter**2*rslope(i,k,1) - praci(i,k) = pi*qci(i,k,2)*n0r*abs(vt2r-vt2i)*acrfac/4. - praci(i,k) = min(praci(i,k),qci(i,k,2)/dtcld) -!------------------------------------------------------------- -! piacr: Accretion of rain by cloud ice [HL A19] [LFO 26] -! (TS or R->G) -!------------------------------------------------------------- - piacr(i,k) = pi**2*avtr*n0r*denr*xni(i,k)*denfac(i,k) & - *g6pbr*rslope3(i,k,1)*rslope3(i,k,1) & - *rslopeb(i,k,1)/24./den(i,k) - piacr(i,k) = min(piacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! psaci: Accretion of cloud ice by snow [HDC 10] -! (TS) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin) then - acrfac = 2.*rslope3(i,k,2)+2.*diameter*rslope2(i,k,2) & - +diameter**2*rslope(i,k,2) - psaci(i,k) = pi*qci(i,k,2)*eacrs*n0s*n0sfac(i,k) & - *abs(vt2ave-vt2i)*acrfac/4. - psaci(i,k) = min(psaci(i,k),qci(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! pgaci: Accretion of cloud ice by graupel [HL A17] [LFO 41] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin) then - egi = exp(0.07*(-supcol)) - acrfac = 2.*rslope3(i,k,3)+2.*diameter*rslope2(i,k,3) & - +diameter**2*rslope(i,k,3) - pgaci(i,k) = pi*egi*qci(i,k,2)*n0g*abs(vt2ave-vt2i)*acrfac/4. - pgaci(i,k) = min(pgaci(i,k),qci(i,k,2)/dtcld) - endif - endif -!------------------------------------------------------------- -! psacw: Accretion of cloud water by snow [HL A7] [LFO 24] -! (TS, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - psacw(i,k) = min(pacrc*n0sfac(i,k)*rslope3(i,k,2)*rslopeb(i,k,2) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacw: Accretion of cloud water by graupel [HL A6] [LFO 40] -! (TG, and T>=T0: C->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qci(i,k,1).gt.qmin) then - pgacw(i,k) = min(pacrg*rslope3(i,k,3)*rslopeb(i,k,3) & - *qci(i,k,1)*denfac(i,k),qci(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! paacw: Accretion of cloud water by averaged snow/graupel -! (TG or S, and T>=T0: C->R) -!------------------------------------------------------------- - if(qsum(i,k) .gt. 1.e-15) then - paacw(i,k) = (qrs(i,k,2)*psacw(i,k)+qrs(i,k,3)*pgacw(i,k)) & - /(qsum(i,k)) - endif -!------------------------------------------------------------- -! pracs: Accretion of snow by rain [HL A11] [LFO 27] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - if(supcol.gt.0) then - acrfac = 5.*rslope3(i,k,2)*rslope3(i,k,2)*rslope(i,k,1) & - +2.*rslope3(i,k,2)*rslope2(i,k,2)*rslope2(i,k,1) & - +.5*rslope2(i,k,2)*rslope2(i,k,2)*rslope3(i,k,1) - pracs(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2r-vt2ave) & - *(dens/den(i,k))*acrfac - pracs(i,k) = min(pracs(i,k),qrs(i,k,2)/dtcld) - endif -!------------------------------------------------------------- -! psacr: Accretion of rain by snow [HL A10] [LFO 28] -! (TS or R->G) (T>=T0: enhance melting of snow) -!------------------------------------------------------------- - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,2) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,2) - psacr(i,k) = pi**2*n0r*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & - *(denr/den(i,k))*acrfac - psacr(i,k) = min(psacr(i,k),qrs(i,k,1)/dtcld) - endif -!------------------------------------------------------------- -! pgacr: Accretion of rain by graupel [HL A12] [LFO 42] -! (TG) (T>=T0: enhance melting of graupel) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,1).gt.qcrmin) then - acrfac = 5.*rslope3(i,k,1)*rslope3(i,k,1)*rslope(i,k,3) & - +2.*rslope3(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & - +.5*rslope2(i,k,1)*rslope2(i,k,1)*rslope3(i,k,3) - pgacr(i,k) = pi**2*n0r*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & - *acrfac - pgacr(i,k) = min(pgacr(i,k),qrs(i,k,1)/dtcld) - endif -! -!------------------------------------------------------------- -! pgacs: Accretion of snow by graupel [HL A13] [LFO 29] -! (S->G): This process is eliminated in V3.0 with the -! new combined snow/graupel fall speeds -!------------------------------------------------------------- - if(qrs(i,k,3).gt.qcrmin.and.qrs(i,k,2).gt.qcrmin) then - pgacs(i,k) = 0. - endif - if(supcol.le.0) then - xlf = xlf0 -!------------------------------------------------------------- -! pseml: Enhanced melting of snow by accretion of water [HL A34] -! (T>=T0: S->R) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) & - pseml(i,k) = min(max(cliq*supcol*(paacw(i,k)+psacr(i,k)) & - /xlf,-qrs(i,k,2)/dtcld),0.) -!------------------------------------------------------------- -! pgeml: Enhanced melting of graupel by accretion of water [HL A24] [RH84 A21-A22] -! (T>=T0: G->R) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0.) & - pgeml(i,k) = min(max(cliq*supcol*(paacw(i,k)+pgacr(i,k)) & - /xlf,-qrs(i,k,3)/dtcld),0.) - endif - if(supcol.gt.0) then -!------------------------------------------------------------- -! pidep: Deposition/Sublimation rate of ice [HDC 9] -! (TI or I->V) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.and.ifsat.ne.1) then - pidep(i,k) = 4.*diameter*xni(i,k)*(rh(i,k,2)-1.)/work1(i,k,2) - supice = satdt-prevp(i,k) - if(pidep(i,k).lt.0.) then - pidep(i,k) = max(max(pidep(i,k),satdt/2),supice) - pidep(i,k) = max(pidep(i,k),-qci(i,k,2)/dtcld) - else - pidep(i,k) = min(min(pidep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)).ge.abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! psdep: deposition/sublimation rate of snow [HDC 14] -! (TS or S->V) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psdep(i,k) = (rh(i,k,2)-1.)*n0sfac(i,k)*(precs1*rslope2(i,k,2) & - + precs2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k) - if(psdep(i,k).lt.0.) then - psdep(i,k) = max(psdep(i,k),-qrs(i,k,2)/dtcld) - psdep(i,k) = max(max(psdep(i,k),satdt/2),supice) - else - psdep(i,k) = min(min(psdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)).ge.abs(satdt)) & - ifsat = 1 - endif -!------------------------------------------------------------- -! pgdep: deposition/sublimation rate of graupel [HL A21] [LFO 46] -! (TG or G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.ifsat.ne.1) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgdep(i,k) = (rh(i,k,2)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,2) - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k) - if(pgdep(i,k).lt.0.) then - pgdep(i,k) = max(pgdep(i,k),-qrs(i,k,3)/dtcld) - pgdep(i,k) = max(max(pgdep(i,k),satdt/2),supice) - else - pgdep(i,k) = min(min(pgdep(i,k),satdt/2),supice) - endif - if(abs(prevp(i,k)+pidep(i,k)+psdep(i,k)+pgdep(i,k)).ge. & - abs(satdt)) ifsat = 1 - endif -!------------------------------------------------------------- -! pigen: generation(nucleation) of ice from vapor [HL 50] [HDC 7-8] -! (TI) -!------------------------------------------------------------- - if(supsat.gt.0.and.ifsat.ne.1) then - supice = satdt-prevp(i,k)-pidep(i,k)-psdep(i,k)-pgdep(i,k) - xni0 = 1.e3*exp(0.1*supcol) - roqi0 = 4.92e-11*xni0**1.33 - pigen(i,k) = max(0.,(roqi0/den(i,k)-max(qci(i,k,2),0.))/dtcld) - pigen(i,k) = min(min(pigen(i,k),satdt),supice) - endif -! -!------------------------------------------------------------- -! psaut: conversion(aggregation) of ice to snow [HDC 12] -! (TS) -!------------------------------------------------------------- - if(qci(i,k,2).gt.0.) then - qimax = roqimax/den(i,k) - psaut(i,k) = max(0.,(qci(i,k,2)-qimax)/dtcld) - endif -! -!------------------------------------------------------------- -! pgaut: conversion(aggregation) of snow to graupel [HL A4] [LFO 37] -! (TG) -!------------------------------------------------------------- - if(qrs(i,k,2).gt.0.) then - alpha2 = 1.e-3*exp(0.09*(-supcol)) - pgaut(i,k) = min(max(0.,alpha2*(qrs(i,k,2)-qs0)),qrs(i,k,2)/dtcld) - endif - endif -! -!------------------------------------------------------------- -! psevp: Evaporation of melting snow [HL A35] [RH83 A27] -! (T>=T0: S->V) -!------------------------------------------------------------- - if(supcol.lt.0.) then - if(qrs(i,k,2).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) - psevp(i,k) = (rh(i,k,1)-1.)*n0sfac(i,k)*(precs1 & - *rslope2(i,k,2)+precs2*work2(i,k) & - *coeres)/work1(i,k,1) - psevp(i,k) = min(max(psevp(i,k),-qrs(i,k,2)/dtcld),0.) - endif -!------------------------------------------------------------- -! pgevp: Evaporation of melting graupel [HL A25] [RH84 A19] -! (T>=T0: G->V) -!------------------------------------------------------------- - if(qrs(i,k,3).gt.0..and.rh(i,k,1).lt.1.) then - coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) - pgevp(i,k) = (rh(i,k,1)-1.)*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres)/work1(i,k,1) - pgevp(i,k) = min(max(pgevp(i,k),-qrs(i,k,3)/dtcld),0.) - endif - endif - enddo - enddo -! -! -!---------------------------------------------------------------- -! check mass conservation of generation terms and feedback to the -! large scale -! - do k = kts, kte - do i = its, ite -! - delta2=0. - delta3=0. - if(qrs(i,k,1).lt.1.e-4.and.qrs(i,k,2).lt.1.e-4) delta2=1. - if(qrs(i,k,1).lt.1.e-4) delta3=1. - if(t(i,k).le.t0c) then -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source = (praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! cloud ice -! - value = max(qmin,qci(i,k,2)) - source = (psaut(i,k)-pigen(i,k)-pidep(i,k)+praci(i,k)+psaci(i,k) & - +pgaci(i,k))*dtcld - if (source.gt.value) then - factor = value/source - psaut(i,k) = psaut(i,k)*factor - pigen(i,k) = pigen(i,k)*factor - pidep(i,k) = pidep(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-praut(i,k)-prevp(i,k)-pracw(i,k)+piacr(i,k)+psacr(i,k) & - +pgacr(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - endif -! -! snow -! - value = max(qmin,qrs(i,k,2)) - source = -(psdep(i,k)+psaut(i,k)-pgaut(i,k)+paacw(i,k)+piacr(i,k) & - *delta3+praci(i,k)*delta3-pracs(i,k)*(1.-delta2) & - +psacr(i,k)*delta2+psaci(i,k)-pgacs(i,k) )*dtcld - if (source.gt.value) then - factor = value/source - psdep(i,k) = psdep(i,k)*factor - psaut(i,k) = psaut(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psaci(i,k) = psaci(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! -! graupel -! - value = max(qmin,qrs(i,k,3)) - source = -(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3)+praci(i,k)*(1.-delta3) & - +psacr(i,k)*(1.-delta2)+pracs(i,k)*(1.-delta2) & - +pgaci(i,k)+paacw(i,k)+pgacr(i,k)+pgacs(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgdep(i,k) = pgdep(i,k)*factor - pgaut(i,k) = pgaut(i,k)*factor - piacr(i,k) = piacr(i,k)*factor - praci(i,k) = praci(i,k)*factor - psacr(i,k) = psacr(i,k)*factor - pracs(i,k) = pracs(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pgaci(i,k) = pgaci(i,k)*factor - pgacr(i,k) = pgacr(i,k)*factor - pgacs(i,k) = pgacs(i,k)*factor - endif -! - work2(i,k)=-(prevp(i,k)+psdep(i,k)+pgdep(i,k)+pigen(i,k)+pidep(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)-piacr(i,k)-pgacr(i,k) & - -psacr(i,k))*dtcld,0.) - qci(i,k,2) = max(qci(i,k,2)-(psaut(i,k)+praci(i,k) & - +psaci(i,k)+pgaci(i,k)-pigen(i,k)-pidep(i,k)) & - *dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psdep(i,k)+psaut(i,k)+paacw(i,k) & - -pgaut(i,k)+piacr(i,k)*delta3 & - +praci(i,k)*delta3+psaci(i,k)-pgacs(i,k) & - -pracs(i,k)*(1.-delta2)+psacr(i,k)*delta2) & - *dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgdep(i,k)+pgaut(i,k) & - +piacr(i,k)*(1.-delta3) & - +praci(i,k)*(1.-delta3)+psacr(i,k)*(1.-delta2) & - +pracs(i,k)*(1.-delta2)+pgaci(i,k)+paacw(i,k) & - +pgacr(i,k)+pgacs(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xls*(psdep(i,k)+pgdep(i,k)+pidep(i,k)+pigen(i,k)) & - -xl(i,k)*prevp(i,k)-xlf*(piacr(i,k)+paacw(i,k) & - +paacw(i,k)+pgacr(i,k)+psacr(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - else -! -! cloud water -! - value = max(qmin,qci(i,k,1)) - source=(praut(i,k)+pracw(i,k)+paacw(i,k)+paacw(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - endif -! -! rain -! - value = max(qmin,qrs(i,k,1)) - source = (-paacw(i,k)-praut(i,k)+pseml(i,k)+pgeml(i,k)-pracw(i,k) & - -paacw(i,k)-prevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - praut(i,k) = praut(i,k)*factor - prevp(i,k) = prevp(i,k)*factor - pracw(i,k) = pracw(i,k)*factor - paacw(i,k) = paacw(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif -! -! snow -! - value = max(qcrmin,qrs(i,k,2)) - source=(pgacs(i,k)-pseml(i,k)-psevp(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - psevp(i,k) = psevp(i,k)*factor - pseml(i,k) = pseml(i,k)*factor - endif -! -! graupel -! - value = max(qcrmin,qrs(i,k,3)) - source=-(pgacs(i,k)+pgevp(i,k)+pgeml(i,k))*dtcld - if (source.gt.value) then - factor = value/source - pgacs(i,k) = pgacs(i,k)*factor - pgevp(i,k) = pgevp(i,k)*factor - pgeml(i,k) = pgeml(i,k)*factor - endif - work2(i,k)=-(prevp(i,k)+psevp(i,k)+pgevp(i,k)) -! update - q(i,k) = q(i,k)+work2(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)-(praut(i,k)+pracw(i,k) & - +paacw(i,k)+paacw(i,k))*dtcld,0.) - qrs(i,k,1) = max(qrs(i,k,1)+(praut(i,k)+pracw(i,k) & - +prevp(i,k)+paacw(i,k)+paacw(i,k)-pseml(i,k) & - -pgeml(i,k))*dtcld,0.) - qrs(i,k,2) = max(qrs(i,k,2)+(psevp(i,k)-pgacs(i,k) & - +pseml(i,k))*dtcld,0.) - qrs(i,k,3) = max(qrs(i,k,3)+(pgacs(i,k)+pgevp(i,k) & - +pgeml(i,k))*dtcld,0.) - xlf = xls-xl(i,k) - xlwork2 = -xl(i,k)*(prevp(i,k)+psevp(i,k)+pgevp(i,k)) & - -xlf*(pseml(i,k)+pgeml(i,k)) - t(i,k) = t(i,k)-xlwork2/cpm(i,k)*dtcld - endif - enddo - enddo -! -! Inline expansion for fpvs -! qs(i,k,1) = fpvs(t(i,k),0,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) -! qs(i,k,2) = fpvs(t(i,k),1,rd,rv,cpv,cliq,cice,xlv0,xls,psat,t0c) - hsub = xls - hvap = xlv0 - cvap = cpv - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - do k = kts, kte - do i = its, ite - tr=ttp/t(i,k) - qs(i,k,1)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - qs(i,k,1) = min(qs(i,k,1),0.99*p(i,k)) - qs(i,k,1) = ep2 * qs(i,k,1) / (p(i,k) - qs(i,k,1)) - qs(i,k,1) = max(qs(i,k,1),qmin) - tr=ttp/t(i,k) - if(t(i,k).lt.ttp) then - qs(i,k,2)=psat*exp(log(tr)*(xai))*exp(xbi*(1.-tr)) - else - qs(i,k,2)=psat*exp(log(tr)*(xa))*exp(xb*(1.-tr)) - endif - qs(i,k,2) = min(qs(i,k,2),0.99*p(i,k)) - qs(i,k,2) = ep2 * qs(i,k,2) / (p(i,k) - qs(i,k,2)) - qs(i,k,2) = max(qs(i,k,2),qmin) - enddo - enddo -! -!---------------------------------------------------------------- -! pcond: condensational/evaporational rate of cloud water [HL A46] [RH83 A6] -! if there exists additional water vapor condensated/if -! evaporation of cloud water is not enough to remove subsaturation -! - do k = kts, kte - do i = its, ite - work1(i,k,1) = conden(t(i,k),q(i,k),qs(i,k,1),xl(i,k),cpm(i,k)) - work2(i,k) = qci(i,k,1)+work1(i,k,1) - pcond(i,k) = min(max(work1(i,k,1)/dtcld,0.),max(q(i,k),0.)/dtcld) - if(qci(i,k,1).gt.0..and.work1(i,k,1).lt.0.) & - pcond(i,k) = max(work1(i,k,1),-qci(i,k,1))/dtcld - q(i,k) = q(i,k)-pcond(i,k)*dtcld - qci(i,k,1) = max(qci(i,k,1)+pcond(i,k)*dtcld,0.) - t(i,k) = t(i,k)+pcond(i,k)*xl(i,k)/cpm(i,k)*dtcld - enddo - enddo -! -! -!---------------------------------------------------------------- -! padding for small values -! - do k = kts, kte - do i = its, ite - if(qci(i,k,1).le.qmin) qci(i,k,1) = 0.0 - if(qci(i,k,2).le.qmin) qci(i,k,2) = 0.0 - enddo - enddo - enddo ! big loops - END SUBROUTINE wsm62d -! ................................................................... - REAL FUNCTION rgmma(x) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -! rgmma function: use infinite product form - REAL :: euler - PARAMETER (euler=0.577215664901532) - REAL :: x, y - INTEGER :: i - if(x.eq.1.)then - rgmma=0. - else - rgmma=x*exp(euler*x) - do i=1,10000 - y=float(i) - rgmma=rgmma*(1.000+x/y)*exp(-x/y) - enddo - rgmma=1./rgmma - endif - END FUNCTION rgmma -! -!-------------------------------------------------------------------------- - REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) -!-------------------------------------------------------------------------- - IMPLICIT NONE -!-------------------------------------------------------------------------- - REAL t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti, & - xai,xbi,ttp,tr - INTEGER ice -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ttp=t0c+0.01 - dldt=cvap-cliq - xa=-dldt/rv - xb=xa+hvap/(rv*ttp) - dldti=cvap-cice - xai=-dldti/rv - xbi=xai+hsub/(rv*ttp) - tr=ttp/t - if(t.lt.ttp.and.ice.eq.1) then - fpvs=psat*(tr**xai)*exp(xbi*(1.-tr)) - else - fpvs=psat*(tr**xa)*exp(xb*(1.-tr)) - endif -! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs -!------------------------------------------------------------------- - SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,hail_opt,allowed_to_read) -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- -!.... constants which may not be tunable - REAL, INTENT(IN) :: den0,denr,dens,cl,cpv - INTEGER, INTENT(IN) :: hail_opt ! RAS - LOGICAL, INTENT(IN) :: allowed_to_read + module module_mp_wsm6 + use mpas_log + use mpas_kind_types,only: RKIND -! RAS13.1 define graupel parameters as graupel-like or hail-like, -! depending on namelist option - IF (hail_opt .eq. 1) THEN !Hail! - n0g = 4.e4 - deng = 700. - avtg = 285.0 - bvtg = 0.8 - lamdagmax = 2.e4 - ELSE !Graupel! - n0g = 4.e6 - deng = 500 - avtg = 330.0 - bvtg = 0.8 - lamdagmax = 6.e4 - ENDIF -! - pi = 4.*atan(1.) - xlv1 = cl-cpv -! - qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 - qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 - pidnc = pi*denr/6. ! syb -! - bvtr1 = 1.+bvtr - bvtr2 = 2.5+.5*bvtr - bvtr3 = 3.+bvtr - bvtr4 = 4.+bvtr - bvtr6 = 6.+bvtr - g1pbr = rgmma(bvtr1) - g3pbr = rgmma(bvtr3) - g4pbr = rgmma(bvtr4) ! 17.837825 - g6pbr = rgmma(bvtr6) - g5pbro2 = rgmma(bvtr2) ! 1.8273 - pvtr = avtr*g4pbr/6. - eacrr = 1.0 - pacrr = pi*n0r*avtr*g3pbr*.25*eacrr - precr1 = 2.*pi*n0r*.78 - precr2 = 2.*pi*n0r*.31*avtr**.5*g5pbro2 - roqimax = 2.08e22*dimax**8 -! - bvts1 = 1.+bvts - bvts2 = 2.5+.5*bvts - bvts3 = 3.+bvts - bvts4 = 4.+bvts - g1pbs = rgmma(bvts1) !.8875 - g3pbs = rgmma(bvts3) - g4pbs = rgmma(bvts4) ! 12.0786 - g5pbso2 = rgmma(bvts2) - pvts = avts*g4pbs/6. - pacrs = pi*n0s*avts*g3pbs*.25 - precs1 = 4.*n0s*.65 - precs2 = 4.*n0s*.44*avts**.5*g5pbso2 - pidn0r = pi*denr*n0r - pidn0s = pi*dens*n0s -! - pacrc = pi*n0s*avts*g3pbs*.25*eacrc -! - bvtg1 = 1.+bvtg - bvtg2 = 2.5+.5*bvtg - bvtg3 = 3.+bvtg - bvtg4 = 4.+bvtg - g1pbg = rgmma(bvtg1) - g3pbg = rgmma(bvtg3) - g4pbg = rgmma(bvtg4) - pacrg = pi*n0g*avtg*g3pbg*.25 - g5pbgo2 = rgmma(bvtg2) - pvtg = avtg*g4pbg/6. - precg1 = 2.*pi*n0g*.78 - precg2 = 2.*pi*n0g*.31*avtg**.5*g5pbgo2 - pidn0g = pi*deng*n0g -! - rslopermax = 1./lamdarmax - rslopesmax = 1./lamdasmax - rslopegmax = 1./lamdagmax - rsloperbmax = rslopermax ** bvtr - rslopesbmax = rslopesmax ** bvts - rslopegbmax = rslopegmax ** bvtg - rsloper2max = rslopermax * rslopermax - rslopes2max = rslopesmax * rslopesmax - rslopeg2max = rslopegmax * rslopegmax - rsloper3max = rsloper2max * rslopermax - rslopes3max = rslopes2max * rslopesmax - rslopeg3max = rslopeg2max * rslopegmax + use mp_wsm6,only: mp_wsm6_run + use mp_wsm6_effectrad,only: mp_wsm6_effectRad_run -!+---+-----------------------------------------------------------------+ -!..Set these variables needed for computing radar reflectivity. These -!.. get used within radar_init to create other variables used in the -!.. radar module. - xam_r = PI*denr/6. - xbm_r = 3. - xmu_r = 0. - xam_s = PI*dens/6. - xbm_s = 3. - xmu_s = 0. - xam_g = PI*deng/6. - xbm_g = 3. - xmu_g = 0. - call radar_init -!+---+-----------------------------------------------------------------+ + implicit none + private + public:: wsm6 -! - END SUBROUTINE wsm6init -!------------------------------------------------------------------------------ - subroutine slope_wsm6(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte,3) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt - REAL, DIMENSION( its:ite , kts:kte) :: & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, lamdas, lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k,1).le.qcrmin)then - rslope(i,k,1) = rslopermax - rslopeb(i,k,1) = rsloperbmax - rslope2(i,k,1) = rsloper2max - rslope3(i,k,1) = rsloper3max - else - rslope(i,k,1) = 1./lamdar(qrs(i,k,1),den(i,k)) - rslopeb(i,k,1) = rslope(i,k,1)**bvtr - rslope2(i,k,1) = rslope(i,k,1)*rslope(i,k,1) - rslope3(i,k,1) = rslope2(i,k,1)*rslope(i,k,1) - endif - if(qrs(i,k,2).le.qcrmin)then - rslope(i,k,2) = rslopesmax - rslopeb(i,k,2) = rslopesbmax - rslope2(i,k,2) = rslopes2max - rslope3(i,k,2) = rslopes3max - else - rslope(i,k,2) = 1./lamdas(qrs(i,k,2),den(i,k),n0sfac(i,k)) - rslopeb(i,k,2) = rslope(i,k,2)**bvts - rslope2(i,k,2) = rslope(i,k,2)*rslope(i,k,2) - rslope3(i,k,2) = rslope2(i,k,2)*rslope(i,k,2) - endif - if(qrs(i,k,3).le.qcrmin)then - rslope(i,k,3) = rslopegmax - rslopeb(i,k,3) = rslopegbmax - rslope2(i,k,3) = rslopeg2max - rslope3(i,k,3) = rslopeg3max - else - rslope(i,k,3) = 1./lamdag(qrs(i,k,3),den(i,k)) - rslopeb(i,k,3) = rslope(i,k,3)**bvtg - rslope2(i,k,3) = rslope(i,k,3)*rslope(i,k,3) - rslope3(i,k,3) = rslope2(i,k,3)*rslope(i,k,3) - endif - vt(i,k,1) = pvtr*rslopeb(i,k,1)*denfac(i,k) - vt(i,k,2) = pvts*rslopeb(i,k,2)*denfac(i,k) - vt(i,k,3) = pvtg*rslopeb(i,k,3)*denfac(i,k) - if(qrs(i,k,1).le.0.0) vt(i,k,1) = 0.0 - if(qrs(i,k,2).le.0.0) vt(i,k,2) = 0.0 - if(qrs(i,k,3).le.0.0) vt(i,k,3) = 0.0 - enddo - enddo - END subroutine slope_wsm6 -!----------------------------------------------------------------------------- - subroutine slope_rain(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdar, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdar(x,y)= sqrt(sqrt(pidn0r/(x*y))) ! (pidn0r/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopermax - rslopeb(i,k) = rsloperbmax - rslope2(i,k) = rsloper2max - rslope3(i,k) = rsloper3max - else - rslope(i,k) = 1./lamdar(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtr - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtr*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_rain -!------------------------------------------------------------------------------ - subroutine slope_snow(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdas, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdas(x,y,z)= sqrt(sqrt(pidn0s*z/(x*y))) ! (pidn0s*z/(x*y))**.25 -! - do k = kts, kte - do i = its, ite - supcol = t0c-t(i,k) -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - n0sfac(i,k) = max(min(exp(alpha*supcol),n0smax/n0s),1.) - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopesmax - rslopeb(i,k) = rslopesbmax - rslope2(i,k) = rslopes2max - rslope3(i,k) = rslopes3max - else - rslope(i,k) = 1./lamdas(qrs(i,k),den(i,k),n0sfac(i,k)) - rslopeb(i,k) = rslope(i,k)**bvts - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvts*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_snow -!---------------------------------------------------------------------------------- - subroutine slope_graup(qrs,den,denfac,t,rslope,rslopeb,rslope2,rslope3, & - vt,its,ite,kts,kte) - IMPLICIT NONE - INTEGER :: its,ite, jts,jte, kts,kte - REAL, DIMENSION( its:ite , kts:kte) :: & - qrs, & - rslope, & - rslopeb, & - rslope2, & - rslope3, & - vt, & - den, & - denfac, & - t - REAL, PARAMETER :: t0c = 273.15 - REAL, DIMENSION( its:ite , kts:kte ) :: & - n0sfac - REAL :: lamdag, x, y, z, supcol - integer :: i, j, k -!---------------------------------------------------------------- -! size distributions: (x=mixing ratio, y=air density): -! valid for mixing ratio > 1.e-9 kg/kg. - lamdag(x,y)= sqrt(sqrt(pidn0g/(x*y))) ! (pidn0g/(x*y))**.25 -! - do k = kts, kte - do i = its, ite -!--------------------------------------------------------------- -! n0s: Intercept parameter for snow [m-4] [HDC 6] -!--------------------------------------------------------------- - if(qrs(i,k).le.qcrmin)then - rslope(i,k) = rslopegmax - rslopeb(i,k) = rslopegbmax - rslope2(i,k) = rslopeg2max - rslope3(i,k) = rslopeg3max - else - rslope(i,k) = 1./lamdag(qrs(i,k),den(i,k)) - rslopeb(i,k) = rslope(i,k)**bvtg - rslope2(i,k) = rslope(i,k)*rslope(i,k) - rslope3(i,k) = rslope2(i,k)*rslope(i,k) - endif - vt(i,k) = pvtg*rslopeb(i,k)*denfac(i,k) - if(qrs(i,k).le.0.0) vt(i,k) = 0.0 - enddo - enddo - END subroutine slope_graup -!--------------------------------------------------------------------------------- -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),precip(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), wd(km), wa(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - enddo - qa(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_rain(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k),ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - rql(i,:) = qn(:) -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm -!------------------------------------------------------------------- - SUBROUTINE nislfv_rain_plm6(im,km,denl,denfacl,tkl,dzl,wwl,rql,rql2, precip1, precip2,dt,id,iter) -!------------------------------------------------------------------- -! -! for non-iteration semi-Lagrangain forward advection for cloud -! with mass conservation and positive definite advection -! 2nd order interpolation with monotonic piecewise linear method -! this routine is under assumption of decfl < 1 for semi_Lagrangian -! -! dzl depth of model layer in meter -! wwl terminal velocity at model layer m/s -! rql cloud density*mixing ration -! precip precipitation -! dt time step -! id kind of precip: 0 test case; 1 raindrop -! iter how many time to guess mean terminal velocity: 0 pure forward. -! 0 : use departure wind for advection -! 1 : use mean wind for advection -! > 1 : use mean wind after iter-1 iterations -! -! author: hann-ming henry juang -! implemented by song-you hong -! - implicit none - integer im,km,id - real dt - real dzl(im,km),wwl(im,km),rql(im,km),rql2(im,km),precip(im),precip1(im),precip2(im) - real denl(im,km),denfacl(im,km),tkl(im,km) -! - integer i,k,n,m,kk,kb,kt,iter,ist - real tl,tl2,qql,dql,qqd - real th,th2,qqh,dqh - real zsum,qsum,dim,dip,c1,con1,fa1,fa2 - real allold, allnew, zz, dzamin, cflmax, decfl - real dz(km), ww(km), qq(km), qq2(km), wd(km), wa(km), wa2(km), was(km) - real den(km), denfac(km), tk(km) - real wi(km+1), zi(km+1), za(km+1) - real qn(km), qr(km),qr2(km),tmp(km),tmp1(km),tmp2(km),tmp3(km) - real dza(km+1), qa(km+1), qa2(km+1),qmi(km+1), qpi(km+1) -! - precip(:) = 0.0 - precip1(:) = 0.0 - precip2(:) = 0.0 -! - i_loop : do i=1,im -! ----------------------------------- - dz(:) = dzl(i,:) - qq(:) = rql(i,:) - qq2(:) = rql2(i,:) - ww(:) = wwl(i,:) - den(:) = denl(i,:) - denfac(:) = denfacl(i,:) - tk(:) = tkl(i,:) -! skip for no precipitation for all layers - allold = 0.0 - do k=1,km - allold = allold + qq(k) + qq2(k) - enddo - if(allold.le.0.0) then - cycle i_loop - endif -! -! compute interface values - zi(1)=0.0 - do k=1,km - zi(k+1) = zi(k)+dz(k) - enddo -! -! save departure wind - wd(:) = ww(:) - n=1 - 100 continue -! plm is 2nd order, we can use 2nd order wi or 3rd order wi -! 2nd order interpolation to get wi - wi(1) = ww(1) - wi(km+1) = ww(km) - do k=2,km - wi(k) = (ww(k)*dz(k-1)+ww(k-1)*dz(k))/(dz(k-1)+dz(k)) - enddo -! 3rd order interpolation to get wi - fa1 = 9./16. - fa2 = 1./16. - wi(1) = ww(1) - wi(2) = 0.5*(ww(2)+ww(1)) - do k=3,km-1 - wi(k) = fa1*(ww(k)+ww(k-1))-fa2*(ww(k+1)+ww(k-2)) - enddo - wi(km) = 0.5*(ww(km)+ww(km-1)) - wi(km+1) = ww(km) -! -! terminate of top of raingroup - do k=2,km - if( ww(k).eq.0.0 ) wi(k)=ww(k-1) - enddo -! -! diffusivity of wi - con1 = 0.05 - do k=km,1,-1 - decfl = (wi(k+1)-wi(k))*dt/dz(k) - if( decfl .gt. con1 ) then - wi(k) = wi(k+1) - con1*dz(k)/dt - endif - enddo -! compute arrival point - do k=1,km+1 - za(k) = zi(k) - wi(k)*dt - enddo -! - do k=1,km - dza(k) = za(k+1)-za(k) - enddo - dza(km+1) = zi(km+1) - za(km+1) -! -! computer deformation at arrival point - do k=1,km - qa(k) = qq(k)*dz(k)/dza(k) - qa2(k) = qq2(k)*dz(k)/dza(k) - qr(k) = qa(k)/den(k) - qr2(k) = qa2(k)/den(k) - enddo - qa(km+1) = 0.0 - qa2(km+1) = 0.0 -! call maxmin(km,1,qa,' arrival points ') -! -! compute arrival terminal velocity, and estimate mean terminal velocity -! then back to use mean terminal velocity - if( n.le.iter ) then - call slope_snow(qr,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa,1,1,1,km) - call slope_graup(qr2,den,denfac,tk,tmp,tmp1,tmp2,tmp3,wa2,1,1,1,km) - do k = 1, km - tmp(k) = max((qr(k)+qr2(k)), 1.E-15) - IF ( tmp(k) .gt. 1.e-15 ) THEN - wa(k) = (wa(k)*qr(k) + wa2(k)*qr2(k))/tmp(k) - ELSE - wa(k) = 0. - ENDIF - enddo - if( n.ge.2 ) wa(1:km)=0.5*(wa(1:km)+was(1:km)) - do k=1,km -!#ifdef DEBUG -! print*,' slope_wsm3 ',qr(k)*1000.,den(k),denfac(k),tk(k),tmp(k),tmp1(k),tmp2(k), & -! ww(k),wa(k) -!#endif -! mean wind is average of departure and new arrival winds - ww(k) = 0.5* ( wd(k)+wa(k) ) - enddo - was(:) = wa(:) - n=n+1 - go to 100 - endif - ist_loop : do ist = 1, 2 - if (ist.eq.2) then - qa(:) = qa2(:) - endif -! - precip(i) = 0. -! -! estimate values at arrival cell interface with monotone - do k=2,km - dip=(qa(k+1)-qa(k))/(dza(k+1)+dza(k)) - dim=(qa(k)-qa(k-1))/(dza(k-1)+dza(k)) - if( dip*dim.le.0.0 ) then - qmi(k)=qa(k) - qpi(k)=qa(k) - else - qpi(k)=qa(k)+0.5*(dip+dim)*dza(k) - qmi(k)=2.0*qa(k)-qpi(k) - if( qpi(k).lt.0.0 .or. qmi(k).lt.0.0 ) then - qpi(k) = qa(k) - qmi(k) = qa(k) - endif - endif - enddo - qpi(1)=qa(1) - qmi(1)=qa(1) - qmi(km+1)=qa(km+1) - qpi(km+1)=qa(km+1) -! -! interpolation to regular point - qn = 0.0 - kb=1 - kt=1 - intp : do k=1,km - kb=max(kb-1,1) - kt=max(kt-1,1) -! find kb and kt - if( zi(k).ge.za(km+1) ) then - exit intp - else - find_kb : do kk=kb,km - if( zi(k).le.za(kk+1) ) then - kb = kk - exit find_kb - else - cycle find_kb - endif - enddo find_kb - find_kt : do kk=kt,km - if( zi(k+1).le.za(kk) ) then - kt = kk - exit find_kt - else - cycle find_kt - endif - enddo find_kt - kt = kt - 1 -! compute q with piecewise constant method - if( kt.eq.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - th=(zi(k+1)-za(kb))/dza(kb) - tl2=tl*tl - th2=th*th - qqd=0.5*(qpi(kb)-qmi(kb)) - qqh=qqd*th2+qmi(kb)*th - qql=qqd*tl2+qmi(kb)*tl - qn(k) = (qqh-qql)/(th-tl) - else if( kt.gt.kb ) then - tl=(zi(k)-za(kb))/dza(kb) - tl2=tl*tl - qqd=0.5*(qpi(kb)-qmi(kb)) - qql=qqd*tl2+qmi(kb)*tl - dql = qa(kb)-qql - zsum = (1.-tl)*dza(kb) - qsum = dql*dza(kb) - if( kt-kb.gt.1 ) then - do m=kb+1,kt-1 - zsum = zsum + dza(m) - qsum = qsum + qa(m) * dza(m) - enddo - endif - th=(zi(k+1)-za(kt))/dza(kt) - th2=th*th - qqd=0.5*(qpi(kt)-qmi(kt)) - dqh=qqd*th2+qmi(kt)*th - zsum = zsum + th*dza(kt) - qsum = qsum + dqh*dza(kt) - qn(k) = qsum/zsum - endif - cycle intp - endif -! - enddo intp -! -! rain out - sum_precip: do k=1,km - if( za(k).lt.0.0 .and. za(k+1).lt.0.0 ) then - precip(i) = precip(i) + qa(k)*dza(k) - cycle sum_precip - else if ( za(k).lt.0.0 .and. za(k+1).ge.0.0 ) then - precip(i) = precip(i) + qa(k)*(0.0-za(k)) - exit sum_precip - endif - exit sum_precip - enddo sum_precip -! -! replace the new values - if(ist.eq.1) then - rql(i,:) = qn(:) - precip1(i) = precip(i) - else - rql2(i,:) = qn(:) - precip2(i) = precip(i) - endif - enddo ist_loop -! -! ---------------------------------- - enddo i_loop -! - END SUBROUTINE nislfv_rain_plm6 - -!+---+-----------------------------------------------------------------+ - - subroutine refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & - t1d, p1d, dBZ, kts, kte, ii, jj) - IMPLICIT NONE + contains -!..Sub arguments - INTEGER, INTENT(IN):: kts, kte, ii, jj - REAL, DIMENSION(kts:kte), INTENT(IN):: & - qv1d, qr1d, qs1d, qg1d, t1d, p1d - REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ -!..Local variables - REAL, DIMENSION(kts:kte):: temp, pres, qv, rho - REAL, DIMENSION(kts:kte):: rr, rs, rg - REAL:: temp_C - - DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilams, ilamg - DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_s, N0_g - DOUBLE PRECISION:: lamr, lams, lamg - LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg +!================================================================================================================= + subroutine wsm6(th,q,qc,qr,qi,qs,qg,den,pii,p,delz, & + delt,g,cpd,cpv,rd,rv,t0c,ep1,ep2,qmin, & + xls,xlv0,xlf0,den0,denr,cliq,cice,psat, & + rain,rainncv,snow,snowncv,graupel,graupelncv,sr, & + refl_10cm,diagflag,do_radar_ref, & + has_reqc,has_reqi,has_reqs,re_qc_bg,re_qi_bg, & + re_qs_bg,re_qc_max,re_qi_max,re_qs_max, & + re_cloud,re_ice,re_snow, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + errmsg,errflg & +#if(WRF_CHEM == 1) + ,wetscav_on,evapprod,rainprod & +#endif + ) +!================================================================================================================= - REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel - DOUBLE PRECISION:: fmelt_s, fmelt_g +!--- input arguments: + logical,intent(in),optional:: diagflag - INTEGER:: i, k, k_0, kbot, n - LOGICAL:: melti + integer,intent(in):: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte - DOUBLE PRECISION:: cback, x, eta, f_d - REAL, PARAMETER:: R=287. + integer,intent(in):: has_reqc,has_reqi,has_reqs + integer,intent(in),optional:: do_radar_ref -!+---+ + real(kind=RKIND),intent(in):: & + delt,g,rd,rv,t0c,den0,cpd,cpv,ep1,ep2,qmin,xls,xlv0,xlf0, & + cliq,cice,psat,denr - do k = kts, kte - dBZ(k) = -35.0 - enddo + real(kind=RKIND),intent(in):: & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max -!+---+-----------------------------------------------------------------+ -!..Put column of data into local arrays. -!+---+-----------------------------------------------------------------+ - do k = kts, kte - temp(k) = t1d(k) - temp_C = min(-0.001, temp(K)-273.15) - qv(k) = MAX(1.E-10, qv1d(k)) - pres(k) = p1d(k) - rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) + real(kind=RKIND),intent(in),dimension(ims:ime,kms:kme,jms:jme ):: & + den, & + pii, & + p, & + delz - if (qr1d(k) .gt. 1.E-9) then - rr(k) = qr1d(k)*rho(k) - N0_r(k) = n0r - lamr = (xam_r*xcrg(3)*N0_r(k)/rr(k))**(1./xcre(1)) - ilamr(k) = 1./lamr - L_qr(k) = .true. - else - rr(k) = 1.E-12 - L_qr(k) = .false. - endif +!inout arguments: + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme):: & + rain,rainncv,sr - if (qs1d(k) .gt. 1.E-9) then - rs(k) = qs1d(k)*rho(k) - N0_s(k) = min(n0smax, n0s*exp(-alpha*temp_C)) - lams = (xam_s*xcsg(3)*N0_s(k)/rs(k))**(1./xcse(1)) - ilams(k) = 1./lams - L_qs(k) = .true. - else - rs(k) = 1.E-12 - L_qs(k) = .false. - endif + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme),optional:: & + snow,snowncv - if (qg1d(k) .gt. 1.E-9) then - rg(k) = qg1d(k)*rho(k) - N0_g(k) = n0g - lamg = (xam_g*xcgg(3)*N0_g(k)/rg(k))**(1./xcge(1)) - ilamg(k) = 1./lamg - L_qg(k) = .true. - else - rg(k) = 1.E-12 - L_qg(k) = .false. - endif - enddo + real(kind=RKIND),intent(inout),dimension(ims:ime,jms:jme),optional:: & + graupel,graupelncv -!+---+-----------------------------------------------------------------+ -!..Locate K-level of start of melting (k_0 is level above). -!+---+-----------------------------------------------------------------+ - melti = .false. - k_0 = kts - do k = kte-1, kts, -1 - if ( (temp(k).gt.273.15) .and. L_qr(k) & - .and. (L_qs(k+1).or.L_qg(k+1)) ) then - k_0 = MAX(k+1, k_0) - melti=.true. - goto 195 - endif - enddo - 195 continue + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + th, & + q, & + qc, & + qi, & + qr, & + qs, & + qg -!+---+-----------------------------------------------------------------+ -!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps) -!.. and non-water-coated snow and graupel when below freezing are -!.. simple. Integrations of m(D)*m(D)*N(D)*dD. -!+---+-----------------------------------------------------------------+ + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme):: & + re_cloud, & + re_ice, & + re_snow - do k = kts, kte - ze_rain(k) = 1.e-22 - ze_snow(k) = 1.e-22 - ze_graupel(k) = 1.e-22 - if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4) - if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_s/900.0)*(xam_s/900.0) & - * N0_s(k)*xcsg(4)*ilams(k)**xcse(4) - if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI)*(6.0/PI) & - * (xam_g/900.0)*(xam_g/900.0) & - * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4) - enddo + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme),optional:: & + refl_10cm +#if(WRF_CHEM == 1) + logical,intent(in):: wetscav_on + real(kind=RKIND),intent(inout),dimension(ims:ime,kms:kme,jms:jme ):: & + rainprod,evapprod +#endif -!+---+-----------------------------------------------------------------+ -!..Special case of melting ice (snow/graupel) particles. Assume the -!.. ice is surrounded by the liquid water. Fraction of meltwater is -!.. extremely simple based on amount found above the melting level. -!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting -!.. routines). -!+---+-----------------------------------------------------------------+ +!output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg - if (melti .and. k_0.ge.kts+1) then - do k = k_0-1, kts, -1 +!local variables and arrays: + logical:: do_microp_re + integer:: i,j,k -!..Reflectivity contributed by melting snow - if (L_qs(k) .and. L_qs(k_0) ) then - fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0)) - eta = 0.d0 - lams = 1./ilams(k) - do n = 1, nrbins - x = xam_s * xxDs(n)**xbm_s - call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), & - fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_s, matrixstring_s, & - inclusionstring_s, hoststring_s, & - hostmatrixstring_s, hostinclusionstring_s) - f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n)) - eta = eta + f_d * CBACK * simpson(n) * xdts(n) - enddo - ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif + real(kind=RKIND),dimension(kts:kte):: qv1d,t1d,p1d,qr1d,qs1d,qg1d,dBZ + real(kind=RKIND),dimension(kts:kte):: den1d,qc1d,qi1d,re_qc,re_qi,re_qs + real(kind=RKIND),dimension(its:ite):: rainncv_hv,rain_hv,sr_hv + real(kind=RKIND),dimension(its:ite):: snowncv_hv,snow_hv + real(kind=RKIND),dimension(its:ite):: graupelncv_hv,graupel_hv + real(kind=RKIND),dimension(its:ite,kts:kte):: t_hv,den_hv,p_hv,delz_hv + real(kind=RKIND),dimension(its:ite,kts:kte):: qv_hv,qc_hv,qi_hv,qr_hv,qs_hv,qg_hv + real(kind=RKIND),dimension(its:ite,kts:kte):: re_qc_hv,re_qi_hv,re_qs_hv -!..Reflectivity contributed by melting graupel +!----------------------------------------------------------------------------------------------------------------- - if (L_qg(k) .and. L_qg(k_0) ) then - fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0)) - eta = 0.d0 - lamg = 1./ilamg(k) - do n = 1, nrbins - x = xam_g * xxDg(n)**xbm_g - call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), & - fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, & - CBACK, mixingrulestring_g, matrixstring_g, & - inclusionstring_g, hoststring_g, & - hostmatrixstring_g, hostinclusionstring_g) - f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n)) - eta = eta + f_d * CBACK * simpson(n) * xdtg(n) - enddo - ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta) - endif + do j = jts,jte + do i = its,ite + !input arguments: + do k = kts,kte + den_hv(i,k) = den(i,k,j) + p_hv(i,k) = p(i,k,j) + delz_hv(i,k) = delz(i,k,j) enddo - endif - - do k = kte, kts, -1 - dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18) - enddo - - - end subroutine refl10cm_wsm6 -!+---+-----------------------------------------------------------------+ - -!----------------------------------------------------------------------- - subroutine effectRad_wsm6 (t, qc, qi, qs, rho, qmin, t0c, & - re_qc, re_qi, re_qs, kts, kte, ii, jj) -!----------------------------------------------------------------------- -! Compute radiation effective radii of cloud water, ice, and snow for -! single-moment microphysics. -! These are entirely consistent with microphysics assumptions, not -! constant or otherwise ad hoc as is internal to most radiation -! schemes. -! Coded and implemented by Soo ya Bae, KIAPS, January 2015. -!----------------------------------------------------------------------- + !inout arguments: + rain_hv(i) = rain(i,j) + + do k = kts,kte + t_hv(i,k) = th(i,k,j)*pii(i,k,j) + qv_hv(i,k) = q(i,k,j) + qc_hv(i,k) = qc(i,k,j) + qi_hv(i,k) = qi(i,k,j) + qr_hv(i,k) = qr(i,k,j) + qs_hv(i,k) = qs(i,k,j) + qg_hv(i,k) = qg(i,k,j) + enddo + enddo - implicit none + if(present(snow) .and. present(snowncv)) then + do i = its,ite + snow_hv(i) = snow(i,j) + enddo + endif + if(present(graupel) .and. present(graupelncv)) then + do i = its,ite + graupel_hv(i) = graupel(i,j) + enddo + endif + +!--- call to cloud microphysics scheme: + call mp_wsm6_run(t=t_hv,q=qv_hv,qc=qc_hv,qi=qi_hv,qr=qr_hv,qs=qs_hv,qg=qg_hv, & + den=den_hv,p=p_hv,delz=delz_hv,delt=delt,g=g,cpd=cpd,cpv=cpv, & + rd=rd,rv=rv,t0c=t0c,ep1=ep1,ep2=ep2,qmin=qmin,xls=xls,xlv0=xlv0, & + xlf0=xlf0,den0=den0,denr=denr,cliq=cliq,cice=cice,psat=psat, & + rain=rain_hv,rainncv=rainncv_hv,sr=sr_hv,snow=snow_hv, & + snowncv=snowncv_hv,graupel=graupel_hv,graupelncv=graupelncv_hv, & + its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg & +#if(WRF_CHEM == 1) + ,rainprod2d=rainprod_hv,evapprod2d=evapprodhv & +#endif + ) + + do i = its,ite + !inout arguments: + rain(i,j) = rain_hv(i) + rainncv(i,j) = rainncv_hv(i) + sr(i,j) = sr_hv(i) + + do k = kts,kte + th(i,k,j) = t_hv(i,k)/pii(i,k,j) + q(i,k,j) = qv_hv(i,k) + qc(i,k,j) = qc_hv(i,k) + qi(i,k,j) = qi_hv(i,k) + qr(i,k,j) = qr_hv(i,k) + qs(i,k,j) = qs_hv(i,k) + qg(i,k,j) = qg_hv(i,k) + enddo + enddo -!..Sub arguments - integer, intent(in) :: kts, kte, ii, jj - real, intent(in) :: qmin - real, intent(in) :: t0c - real, dimension( kts:kte ), intent(in):: t - real, dimension( kts:kte ), intent(in):: qc - real, dimension( kts:kte ), intent(in):: qi - real, dimension( kts:kte ), intent(in):: qs - real, dimension( kts:kte ), intent(in):: rho - real, dimension( kts:kte ), intent(inout):: re_qc - real, dimension( kts:kte ), intent(inout):: re_qi - real, dimension( kts:kte ), intent(inout):: re_qs -!..Local variables - integer:: i,k - integer :: inu_c - real, dimension( kts:kte ):: ni - real, dimension( kts:kte ):: rqc - real, dimension( kts:kte ):: rqi - real, dimension( kts:kte ):: rni - real, dimension( kts:kte ):: rqs - real :: temp - real :: lamdac - real :: supcol, n0sfac, lamdas - real :: diai ! diameter of ice in m - logical :: has_qc, has_qi, has_qs -!..Minimum microphys values - real, parameter :: R1 = 1.E-12 - real, parameter :: R2 = 1.E-6 -!..Mass power law relations: mass = am*D**bm - real, parameter :: bm_r = 3.0 - real, parameter :: obmr = 1.0/bm_r - real, parameter :: nc0 = 3.E8 -!----------------------------------------------------------------------- - has_qc = .false. - has_qi = .false. - has_qs = .false. + if(present(snow) .and. present(snowncv)) then + do i = its,ite + snow(i,j) = snow_hv(i) + snowncv(i,j) = snowncv_hv(i) + enddo + endif + if(present(graupel) .and. present(graupelncv)) then + do i = its,ite + graupel(i,j) = graupel_hv(i) + graupelncv(i,j) = graupelncv_hv(i) + enddo + endif + +#if(WRF_CHEM == 1) + if(wetscav_on) then + do k = kts,kte + do i = its, ite + rainprod(i,k,j) = rainprod_hv(i,k) + evapprod(i,k,j) = evapprod_hv(i,k) + enddo + enddo + else + do k = kts,kte + do i = its, ite + rainprod(i,k,j) = 0. + evapprod(i,k,j) = 0. + enddo + enddo + endif +#endif - do k = kts, kte - ! for cloud - rqc(k) = max(R1, qc(k)*rho(k)) - if (rqc(k).gt.R1) has_qc = .true. - ! for ice - rqi(k) = max(R1, qi(k)*rho(k)) - temp = (rho(k)*max(qi(k),qmin)) - temp = sqrt(sqrt(temp*temp*temp)) - ni(k) = min(max(5.38e7*temp,1.e3),1.e6) - rni(k)= max(R2, ni(k)*rho(k)) - if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. - ! for snow - rqs(k) = max(R1, qs(k)*rho(k)) - if (rqs(k).gt.R1) has_qs = .true. - enddo +!--- call to computation of effective radii for cloud water, cloud ice, and snow: + do_microp_re = .false. + if(has_reqc == 1 .and. has_reqi == 1 .and. has_reqs == 1) do_microp_re = .true. - if (has_qc) then - do k=kts,kte - if (rqc(k).le.R1) CYCLE - lamdac = (pidnc*nc0/rqc(k))**obmr - re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + do k = kts,kte + do i = its,ite + t_hv(i,k) = th(i,k,j)*pii(i,k,j) + re_qc_hv(i,k) = re_cloud(i,k,j) + re_qi_hv(i,k) = re_ice(i,k,j) + re_qs_hv(i,k) = re_snow(i,k,j) enddo - endif + enddo - if (has_qi) then - do k=kts,kte - if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE - diai = 11.9*sqrt(rqi(k)/ni(k)) - re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) - enddo - endif + call mp_wsm6_effectRad_run(do_microp_re,t_hv,qc_hv,qi_hv,qs_hv,den_hv,qmin,t0c, & + re_qc_bg,re_qi_bg,re_qs_bg,re_qc_max,re_qi_max,re_qs_max,re_qc_hv, & + re_qi_hv,re_qs_hv,its,ite,kts,kte,errmsg,errflg) - if (has_qs) then - do k=kts,kte - if (rqs(k).le.R1) CYCLE - supcol = t0c-t(k) - n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) - lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) - re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + do k = kts,kte + do i = its,ite + re_cloud(i,k,j) = re_qc_hv(i,k) + re_ice(i,k,j) = re_qi_hv(i,k) + re_snow(i,k,j) = re_qs_hv(i,k) enddo - endif + enddo + + enddo - end subroutine effectRad_wsm6 -!----------------------------------------------------------------------- + end subroutine wsm6 -END MODULE module_mp_wsm6 +!================================================================================================================= + end module module_mp_wsm6 +!================================================================================================================= 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_ra_cam_support.F b/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F index 37fd487e07..5a3699aa7f 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_cam_support.F @@ -4,11 +4,16 @@ MODULE module_ra_cam_support ! background. ! Laura D. Fowler (birch.ucar.edu) / 2013-07-01. use mpas_atmphys_utilities -#endif + use mpas_kind_types, only : R8KIND + use mpas_io_units, only: mpas_new_unit, mpas_release_unit + implicit none + integer, parameter :: r8 = R8KIND +#else implicit none integer, parameter :: r8 = 8 +#endif real(r8), parameter:: inf = 1.e20 ! CAM sets this differently in infnan.F90 - integer, parameter:: bigint = O'17777777777' ! largest possible 32-bit integer + integer, parameter:: bigint = int(O'17777777777') ! largest possible 32-bit integer integer :: ixcldliq integer :: ixcldice @@ -3344,12 +3349,19 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & WRITE(message,*)'num_months = ',num_months CALL wrf_debug(50,message) +#if defined(mpas) + call mpas_new_unit(pin_unit) +#else pin_unit = 27 +#endif OPEN(pin_unit, FILE='ozone_plev.formatted',FORM='FORMATTED',STATUS='OLD') do k = 1,levsiz READ (pin_unit,*)pin(k) end do - close(27) + close(pin_unit) +#if defined(mpas) + call mpas_release_unit(pin_unit) +#endif do k=1,levsiz pin(k) = pin(k)*100. @@ -3357,17 +3369,28 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & !-- read in ozone lat data +#if defined(mpas) + call mpas_new_unit(lat_unit) +#else lat_unit = 28 +#endif OPEN(lat_unit, FILE='ozone_lat.formatted',FORM='FORMATTED',STATUS='OLD') do j = 1,latsiz READ (lat_unit,*)lat_ozone(j) end do - close(28) + close(lat_unit) +#if defined(mpas) + call mpas_release_unit(lat_unit) +#endif !-- read in ozone data +#if defined(mpas) + call mpas_new_unit(oz_unit) +#else oz_unit = 29 +#endif OPEN(oz_unit, FILE='ozone.formatted',FORM='FORMATTED',STATUS='OLD') do m=2,num_months @@ -3379,7 +3402,10 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & enddo enddo enddo - close(29) + close(oz_unit) +#if defined(mpas) + call mpas_release_unit(oz_unit) +#endif !-- latitudinally interpolate ozone data (and extend longitudinally) diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F index a2ee96b621..49f8169a45 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw.F @@ -9840,6 +9840,13 @@ MODULE module_ra_rrtmg_sw !> microphysics scheme as inputs to the subroutine rrtmg_swrad. revised the initialization of arrays rel, !> rei, and res, accordingly. !> Laura D. Fowler (laura@ucar.edu) / 2016-07-07. +!> * added the optional arguments, tauaer3d, ssaaer3d, and asyaer3d to include the optical depth, single +!> scattering albedo, and asymmetry factor of aerosols. to date, the only kind of aerosols included in MPAS +!> are the "water-friendly" and "ice-friendly" aerosols used in the Thompson cloud microphysics scheme. +!> Laura D. Fowler (laura@ucar.edu) / 2024-05-16. +!> * added the option aer_opt in the argument list. revised the initialization of arrays tauaer,ssaaer, and +!> asmaer to include the optical properties of aerosols. +!> Laura D. Fowler (laura@ucar.edu) / 2024-05-16. !MPAS specfic end. #else @@ -9873,9 +9880,11 @@ subroutine rrtmg_swrad( & noznlevels,pin,o3clim,gsw,swcf,rthratensw, & has_reqc,has_reqi,has_reqs,re_cloud, & re_ice,re_snow, & - swupt, swuptc, swdnt, swdntc, & - swupb, swupbc, swdnb, swdnbc, & + aer_opt,tauaer3d,ssaaer3d,asyaer3d, & + swupt,swuptc,swdnt,swdntc, & + swupb,swupbc,swdnb,swdnbc, & swupflx, swupflxc, swdnflx, swdnflxc, & + swddir,swddni,swddif, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -9908,6 +9917,12 @@ subroutine rrtmg_swrad( & real,intent(in),dimension(1:noznlevels),optional:: pin real,intent(in),dimension(ims:ime,1:noznlevels,jms:jme),optional:: o3clim +!--- additional input arguments of the aerosol optical depth, single scattering albedo, and asymmetry factor. to +! date, the only kind of aerosols included in MPAS are the "water-friendly" and "ice-friendly" aerosols used +! in the Thompson cloud microphysics scheme: + integer,intent(in),optional:: aer_opt + real,intent(in),dimension(ims:ime,kms:kme,jms:jme,1:nbndsw),optional:: tauaer3d,ssaaer3d,asyaer3d + !--- inout arguments: real,intent(inout),dimension(ims:ime,jms:jme):: coszr,gsw,swcf real,intent(inout),dimension(ims:ime,jms:jme),optional:: & @@ -9916,6 +9931,8 @@ subroutine rrtmg_swrad( & real,intent(inout),dimension(ims:ime,kms:kme,jms:jme):: rthratensw !--- output arguments: + real,intent(out),dimension(ims:ime,jms:jme),optional:: & + swddir,swddni,swddif real,intent(out),dimension(ims:ime,kms:kme+2,jms:jme ),optional:: & swupflx,swupflxc,swdnflx,swdnflxc @@ -9964,7 +9981,6 @@ subroutine rrtmg_swrad( & !--- additional local variables related to the implementation of aerosols in rrtmg_swrad in WRF 3.8. ! In WRF 3.8, these variables are in the argument list of subroutine rrtmg_swrad, but are made ! local here: - integer:: aer_opt real,dimension(1,kts:kte+1,naerec):: ecaer !--- set trace gas volume mixing ratios, 2005 values, IPCC (2007): @@ -10128,7 +10144,6 @@ subroutine rrtmg_swrad( & enddo !--- initialization of aerosol optical properties: - aer_opt = 0 do n = 1, ncol do k = 1, nlay do na = 1, naerec @@ -10364,13 +10379,27 @@ subroutine rrtmg_swrad( & fsfcmcl) !--- initialization of aerosol optical properties: - do nb = 1, nbndsw - do k = kts, kte+1 + if(present(tauaer3d) .and. present(ssaaer3d) .and. present(asyaer3d)) then + do nb = 1, nbndsw + do k = kts, kte + tauaer(ncol,k,nb) = tauaer3d(i,k,j,nb) + ssaaer(ncol,k,nb) = ssaaer3d(i,k,j,nb) + asmaer(ncol,k,nb) = asyaer3d(i,k,j,nb) + enddo + k = kte+1 tauaer(ncol,k,nb) = 0. ssaaer(ncol,k,nb) = 1. asmaer(ncol,k,nb) = 0. enddo - enddo + else + do nb = 1, nbndsw + do k = kts, kte+1 + tauaer(ncol,k,nb) = 0. + ssaaer(ncol,k,nb) = 1. + asmaer(ncol,k,nb) = 0. + enddo + enddo + endif do na = 1, naerec do k = kts, kte+1 @@ -10411,6 +10440,12 @@ subroutine rrtmg_swrad( & swdnbc(i,j) = swdflxc(1,1) endif + if(present(swddir) .and. present(swddni) .and. present(swddif)) then + swddir(i,j) = swdkdir(1,1) ! jararias 2013/08/10 + swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10 + swddif(i,j) = swdkdif(1,1) ! jararias 2013/08/10 + endif + if(present (swupflx)) then do k = kts, kte+2 swupflx(i,k,j) = swuflx(1,k) diff --git a/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw_aerosols.F b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw_aerosols.F new file mode 100644 index 0000000000..58ba658886 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_ra_rrtmg_sw_aerosols.F @@ -0,0 +1,925 @@ +!================================================================================================================= +!module_ra_rrtmg_sw_aerosols includes subroutine calc_aerosol_rrtmg_sw. subroutine calc_aerosol_rrtmg_sw is called +!from subroutine radiation_sw_from_MPAS in mpas_atmphys_driver_radiation_sw.F. calc_aerosol_rrtmg_sw calculates +!the optical properties (aerosol optical depth,asymmetry factor,and single-scattering albedo) of "water-friendly" +!and "ice-friendly" aerosols from the Thompson cloud microphysics scheme. calc_aerosol_rrtmg_sw was copied from +!from WRF-4.0.2 (see module_radiation_driver.F). +!Laura D. Fowler (laura@ucar.edu) / 2024-05-16. + + module module_ra_rrtmg_sw_aerosols + use mpas_log + use mpas_atmphys_functions,only: rslf + use mpas_atmphys_utilities, only: physics_error_fatal,physics_message +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) + + implicit none + private + public:: calc_aerosol_rrtmg_sw + + + contains + + +!================================================================================================================= +!-------------------------------------------------------------- +! INDICES CONVENTION +!-------------------------------------------------------------- +! kms:kme define the range for full-level indices +! kts:kte define the range for half-level indices +! +! kms=1 is the first full level at surface +! kts=1 is the first half level at surface +! +! kme is the last full level at toa +! kte is the last half level at toa +! +! There is one more full level than half levels. +! Therefore, kme=kte+1. I checked it in one of my +! simulations: +! +! namelist.input: +! s_vert=1 e_vert=28 +! code: +! kms= 1 kts= 1 +! kms=28 kte=27 +! +! In the vertical dimension there is no tiling for +! parallelization as in the horizontal dimensions. +! For i-dim and j-dim, the t-indices define the +! range of indices over which each tile runs. +!-------------------------------------------------------------- +! +! namelist options: +! aer_aod550_opt = [1,2] : +! 1 = input constant value for AOD at 550 nm from namelist. +! In this case, the value is read from aer_aod550_val; +! 2 = input value from auxiliary input 15. It is a time-varying 2D grid in netcdf wrf-compatible +! format. The default operation is aer_aod550_opt=1 and aer_aod550_val=0.12 +! aer_angexp_opt = [1,2,3] : +! 1 = input constant value for Angstrom exponent from namelist. In this case, the value is read +! from aer_angexp_val; +! 2 = input value from auxiliary input 15, as in aer_aod550_opt; +! 3 = Angstrom exponent value estimated from the aerosol type defined in aer_type, and modulated +! with the RH in WRF. Default operation is aer_angexp_opt = 1, and aer_angexp_val=1.3. +! aer_ssa_opt and aer_asy_opt are similar to aer_angexp_opt. +! +! aer_type = [1,2,3] : 1 for rural, 2 is urban and 3 is maritime. +!-------------------------------------------------------------- + +subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, & + aer_aod550_opt, aer_angexp_opt, aer_ssa_opt, aer_asy_opt, & + aer_aod550_val, aer_angexp_val, aer_ssa_val, aer_asy_val, & + aod5502d, angexp2d, aerssa2d, aerasy2d, & + ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, & + tauaer, ssaaer, asyaer, aod5503d ) + + ! constants + integer, parameter :: N_BANDS=14 + ! local index variables + integer :: i,j,k,nb + + real :: lower_wvl(N_BANDS),upper_wvl(N_BANDS) + data (lower_wvl(i),i=1,N_BANDS) /3.077,2.500,2.150,1.942,1.626,1.299,1.242,0.7782,0.6250,0.4415,0.3448,0.2632,0.2000,3.846/ + data (upper_wvl(i),i=1,N_BANDS) /3.846,3.077,2.500,2.150,1.942,1.626,1.299,1.2420,0.7782,0.6250,0.4415,0.3448,0.2632,12.195/ + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: p, & ! pressure (Pa) + t3d, & ! temperature (K) + dz8w, & ! dz between full levels (m) + qv3d ! water vapor mixing ratio (kg/kg) +!-- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type + character(len=256):: wrf_err_message +!-- end MPAS modifications.. + integer, intent(in) :: aer_aod550_opt, aer_angexp_opt, aer_ssa_opt, aer_asy_opt + real, intent(in) :: aer_aod550_val, aer_angexp_val, aer_ssa_val, aer_asy_val + + real, dimension(ims:ime, jms:jme), intent(in) :: ht + real, dimension(ims:ime, jms:jme), optional, intent(inout) :: aod5502d, angexp2d, aerssa2d, aerasy2d + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: tauaer, ssaaer, asyaer + + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: aod5503d ! trude + + ! local variables + real :: angexp_val,aod_rate,x,xy,xx + real, dimension(ims:ime, jms:jme, 1:N_BANDS) :: aod550spc + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS) :: aod550spc3d ! trude + real, dimension(ims:ime, kms:kme, jms:jme) :: rh ! relative humidity + + call calc_relative_humidity(p,t3d,qv3d, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh ) + + aer_aod550_opt_select: select case(aer_aod550_opt) + !case(0) + ! reserved for climatology + case(1) + if (aer_aod550_val .lt. 0) then + write(wrf_err_message,'("aer_aod550_val must be positive. Negative value ",F7.4," found")') aer_aod550_val + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, '("aer_aod550_opt=",I1,": AOD@550 nm fixed to value ",F6.3)') aer_aod550_opt,aer_aod550_val + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + aod5502d(i,j)=aer_aod550_val + end do + end do + + case(2) + if (.not.(present(aod5502d))) then + write(wrf_err_message,*) 'Expected gridded total AOD@550 nm, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + if (minval(aod5502d) .lt. 0) then + FATAL_ERROR('AOD@550 must be positive. Negative value(s) found in auxinput') + end if +! call mpas_log_write('--- aer_aod550_opt = $i: AOD@550 nm read from auxinput min = $r max = $r', & +! intArgs=(/aer_aod550_opt/),realArgs=(/minval(aod5502d(its:ite,jts:jte)), & +! maxval(aod5502d(its:ite,jts:jte))/)) + case default + write(wrf_err_message,*) 'Expected aer_aod550_opt=[1,2]. Got',aer_aod550_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_aod550_opt_select + + + ! here, the 3d aod550 is calculated according to the aer_angexp_opt case + aer_angexp_opt_select: select case(aer_angexp_opt) + !case(0) + ! reserved for climatology + case(1) + if (aer_angexp_val .lt. -0.3) then + write(wrf_err_message,'("WARNING: aer_angexp_val limited to -0.3. Illegal value ",F7.4," found")') aer_angexp_val + WRITE_MESSAGE(trim(wrf_err_message)) + end if + if (aer_angexp_val .gt. 2.5) then + write(wrf_err_message,'("WARNING: aer_angexp_val limited to 2.5. Illegal value ",F7.4," found")') aer_angexp_val + WRITE_MESSAGE(trim(wrf_err_message)) + end if + write( wrf_err_message , '("aer_angexp_opt=",I1,": Aerosol Angstrom exponent fixed to value ",F6.3)') & + aer_angexp_opt,aer_angexp_val + WRITE_MESSAGE(trim(wrf_err_message)) + angexp_val=min(2.5,max(-0.3,aer_angexp_val)) + do nb=1,N_BANDS + if ((angexp_val .lt. 0.999) .or. (angexp_val .gt. 1.001)) then + aod_rate=((0.55**angexp_val)*(upper_wvl(nb)**(1.-angexp_val)- & + lower_wvl(nb)**(1.-angexp_val)))/((1.-angexp_val)*(upper_wvl(nb)-lower_wvl(nb))) + else + aod_rate=(0.55/(upper_wvl(nb)-lower_wvl(nb)))*log(upper_wvl(nb)/lower_wvl(nb)) + end if + do j=jts,jte + do i=its,ite + aod550spc(i,j,nb)=aod5502d(i,j)*aod_rate + end do + end do + end do + do j=jts,jte + do i=its,ite + angexp2d(i,j)=angexp_val + end do + end do + case(2) + if (.not.(present(angexp2d))) then + write(wrf_err_message,*) 'Expected gridded aerosol Angstrom exponent, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, '("aer_angexp_opt=",I1,": Angstrom exponent read from auxinput (min=",F6.3," max=",F6.3,")")') & + aer_angexp_opt,minval(angexp2d),maxval(angexp2d) + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + angexp_val=min(2.5,max(-0.3,angexp2d(i,j))) + do nb=1,N_BANDS + if ((angexp_val .lt. 0.999) .or. (angexp_val .gt. 1.001)) then + aod_rate=((0.55**angexp_val)*(upper_wvl(nb)**(1.-angexp_val)- & + lower_wvl(nb)**(1.-angexp_val)))/((1.-angexp_val)*(upper_wvl(nb)-lower_wvl(nb))) + else + aod_rate=(0.55/(upper_wvl(nb)-lower_wvl(nb)))*log(upper_wvl(nb)/lower_wvl(nb)) + end if + aod550spc(i,j,nb)=aod5502d(i,j)*aod_rate + end do + end do + end do + + case(3) + ! spectral disaggregation based on a prescribed aerosol type and relative humidity +! call mpas_log_write('--- aer_angexp_opt = $i: angstrom exponent calculated from RH and aer_type $i', & +! intArgs=(/aer_angexp_opt,aer_type/)) + call calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,aod5502d, & + aod550spc, & + aod5503d, aod550spc3d) ! trude + +!-- MPAS modifications: we do not need the variable angexp2d outside of subroutine calc_aerosol_rrtmg_sw. Since it is +! declared as an optional variable, we simply test if it is present or not (Laura D. Fowler/2019-01-13): + if(present(angexp2d)) then + do j=jts,jte + do i=its,ite + angexp2d(i,j) = 0.0 + enddo + enddo + + if (present(aod5503d)) then + do j=jts,jte + do k=kts,kte + do i=its,ite + xy=0 + xx=0 + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + ! the slope of a linear regression with intercept=0 is m=E(xy)/E(x^2), where y=m*x + x=log(0.5*(lower_wvl(nb)+upper_wvl(nb))/0.55) + xy=xy+x*log(aod550spc3d(i,k,j,nb)/aod5503d(i,k,j)) + xx=xx+x*x + end do + angexp2d(i,j) = angexp2d(i,j) - (xy/(N_BANDS-3-8+1))/(xx/(N_BANDS-3-8+1)) + enddo + enddo + enddo + else + + ! added July, 16th, 2013: angexp2d is in the wrfout when aer_angexp_opt=3. It is the average + ! value in the spectral bands between 0.4 and 1. um + do j=jts,jte + do i=its,ite + xy=0 + xx=0 + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + ! the slope of a linear regression with intercept=0 is m=E(xy)/E(x^2), where y=m*x + x=log(0.5*(lower_wvl(nb)+upper_wvl(nb))/0.55) + xy=xy+x*log(aod550spc(i,j,nb)/aod5502d(i,j)) + xx=xx+x*x + end do + angexp2d(i,j)=-(xy/(N_BANDS-3-8+1))/(xx/(N_BANDS-3-8+1)) + end do + end do + endif + endif ! end MPAS modifications. + + case default + write(wrf_err_message,*) 'Expected aer_angexp_opt=[1,2,3]. Got',aer_angexp_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_angexp_opt_select + +!..If 3D AOD (at 550nm) was provided explicitly, then no need to assume a +!.. vertical distribution, just use what was provided. (Trude) + + if (present(aod5503d)) then + do nb=1,N_BANDS + do j=jts,jte + do k=kts,kte + do i=its,ite + tauaer(i,k,j,nb) = aod550spc3d(i,k,j,nb) + enddo + enddo + enddo + enddo + else + ! exponental -vertical- profile + call aod_profiler(ht,dz8w,aod550spc,n_bands,ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte,tauaer ) + endif + + aer_ssa_opt_select: select case(aer_ssa_opt) + !case(0) + ! reserved for climatology + case(1) + if ((aer_ssa_val .lt. 0) .or. (aer_ssa_val .gt. 1)) then + write(wrf_err_message,'("aer_ssa_val must be within [0,1]. Illegal value ",F7.4," found")') aer_ssa_val + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, & + '("aer_ssa_opt=",I1,": single-scattering albedo fixed to value ",F6.3)') aer_ssa_opt,aer_ssa_val + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + ! no spectral disaggregation + ssaaer(i,k,j,nb)=aer_ssa_val + end do + end do + end do + end do + do j=jts,jte + do i=its,ite + aerssa2d(i,j)=aer_ssa_val + end do + end do + + case(2) + if (.not.(present(aerssa2d))) then + write(wrf_err_message,*) 'Expected gridded aerosol single-scattering albedo, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + if ((minval(aerssa2d) .lt. 0) .or. (maxval(aerssa2d) .gt. 1)) then + write(wrf_err_message,*) 'Aerosol single-scattering albedo must be within [0,1]. ' // & + 'Out of bounds value(s) found in auxinput' + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message, '("aer_ssa_opt=",I1,": single-scattering albedo from auxinput (min=",F6.3," max=",F6.3,")")') & + aer_ssa_opt,minval(aerssa2d),maxval(aerssa2d) + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + ! no spectral disaggregation + ssaaer(i,k,j,nb)=aerssa2d(i,j) + end do + end do + end do + end do + + case(3) + ! spectral disaggregation based on a prescribed aerosol type and relative humidity +! call mpas_log_write('--- aer_ssa_opt = $i: single-scattering albedo calculated from RH and aer_type $i', & +! intArgs=(/aer_ssa_opt,aer_type/)) + call calc_spectral_ssa_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,ssaaer ) +!-- MPAS modifications: we do not need the variable aerssa2d outside of subroutine calc_aerosol_rrtmg_sw. Since it is +! declared as an optional variable, we simply test if it is present or not (Laura D. Fowler/2018=04-09): + if(present(aerssa2d)) then + ! added July, 16th, 2013: aerssa2d is in the wrfout when aer_ssa_opt=3. It is the average + ! value in the spectral bands between 0.4 and 1. um + do j=jts,jte + do i=its,ite + aerssa2d(i,j)=0 + end do + end do + do j=jts,jte + do i=its,ite + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + aerssa2d(i,j)=aerssa2d(i,j)+ssaaer(i,kts,j,nb) + end do + aerssa2d(i,j)=aerssa2d(i,j)/(N_BANDS-3-8+1) + end do + end do + endif ! end MPAS modifications. + + case default + write(wrf_err_message,*) 'Expected aer_ssa_opt=[1,2,3]. Got',aer_ssa_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_ssa_opt_select + + aer_asy_opt_select: select case(aer_asy_opt) + !case(0) + ! reserved for climatology + case(1) + if ((aer_asy_val .lt. 0) .or. (aer_asy_val .gt. 1)) then + write(wrf_err_message,'("aer_asy_val must be withing [-1,1]. Illegal value ",F7.4," found")') aer_asy_val + FATAL_ERROR(trim(wrf_err_message)) + end if + write( wrf_err_message , '("aer_asy_opt=",I1,": asymmetry parameter fixed to value ",F6.3)') aer_asy_opt,aer_asy_val + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + asyaer(i,k,j,nb)=aer_asy_val + end do + end do + end do + end do + do j=jts,jte + do i=its,ite + aerasy2d(i,j)=aer_asy_val + end do + end do + + case(2) + if (.not.(present(aerasy2d))) then + write(wrf_err_message,*) 'Expected gridded aerosol asymmetry parameter, but it is not in the radiation driver' + FATAL_ERROR(trim(wrf_err_message)) + end if + if ((minval(aerasy2d) .lt. -1) .or. (maxval(aerasy2d) .gt. 1)) then + FATAL_ERROR('Aerosol asymmetry parameter must be within [-1,1]. Out of bounds value(s) found in auxinput') + end if + write( wrf_err_message, '("aer_asy_opt=",I1,": asymmetry parameter read from auxinput (min=",F6.3," max=",F6.3,")")') & + aer_asy_opt,minval(aerasy2d),maxval(aerasy2d) + WRITE_MESSAGE(trim(wrf_err_message)) + do j=jts,jte + do i=its,ite + do k=kts,kte + do nb=1,N_BANDS + asyaer(i,k,j,nb)=aerasy2d(i,j) + end do + end do + end do + end do + + case(3) + ! spectral disaggregation based on a prescribed aerosol type and relative humidity +! call mpas_log_write('--- aer_asy_opt = $i: asymmetry parameter calculated from RH and aer_type $i', & +! intArgs=(/aer_asy_opt,aer_type/)) + call calc_spectral_asy_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,asyaer ) +!-- MPAS modifications: we do not need the variable aerasy2d outside of subroutine calc_aerosol_rrtmg_sw. Since it is +! declared as an optional variable, we simply test if it is present or not (Laura D. Fowler/2018=04-09): + if(present(aerasy2d)) then + ! added July, 16th, 2013: aerasy2d is in the wrfout when aer_asy_opt=3. It is the average + ! value in the spectral bands between 0.4 and 1. um + do j=jts,jte + do i=its,ite + aerasy2d(i,j)=0 + end do + end do + do j=jts,jte + do i=its,ite + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + aerasy2d(i,j)=aerasy2d(i,j)+asyaer(i,kts,j,nb) + end do + aerasy2d(i,j)=aerasy2d(i,j)/(N_BANDS-3-8+1) + end do + end do + endif ! end MPAS modifications. + + case default + write(wrf_err_message,*) 'Expected aer_asy_opt=[1,2,3]. Got',aer_asy_opt + FATAL_ERROR(trim(wrf_err_message)) + end select aer_asy_opt_select + +end subroutine calc_aerosol_rrtmg_sw + +subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,aod550, & + tauaer, & + aod550_3d, tauaer3d) ! trude + + implicit none + + ! constants + integer, parameter :: N_AER_TYPES=3 + integer, parameter :: N_RH=8 + integer, parameter :: N_BANDS=14 + integer, parameter :: N_INT_POINTS=4 + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte +!- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer:: aer_t + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type +!- end MPAS modifications (Laura D. Fowler/2018=04-09). + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: rh ! relative humidity + real, dimension(ims:ime, jms:jme), intent(in) :: aod550 ! Total AOD at 550 nm at surface + real, dimension(ims:ime, jms:jme, 1:N_BANDS), intent(inout) :: tauaer ! Total spectral aerosol optical depth at surface + + ! ++ Trude + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: aod550_3d ! 3D AOD at 550 nm + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), optional, intent(inout) :: tauaer3d ! + ! -- Trude + + ! local variables + integer :: i,j,k,ib,imax,imin,ii,jj,kk + real :: rhs(N_RH),lj + real :: raod_lut(N_AER_TYPES,N_BANDS,N_RH) + + ! relative humidity steps + data (rhs(i),i=1,8) /0.,50.,70.,80.,90.,95.,98.,99./ + + ! aer_type = 1 : rural (SF79) + data (raod_lut(1,ib,1),ib=1,N_BANDS) /0.0735,0.0997,0.1281,0.1529,0.1882,0.2512,0.3010,0.4550,0.7159,1.0357, & + 1.3582,1.6760,2.2523,0.0582/ + data (raod_lut(1,ib,2),ib=1,N_BANDS) /0.0741,0.1004,0.1289,0.1537,0.1891,0.2522,0.3021,0.4560,0.7166,1.0351, & + 1.3547,1.6687,2.2371,0.0587/ + data (raod_lut(1,ib,3),ib=1,N_BANDS) /0.0752,0.1017,0.1304,0.1554,0.1909,0.2542,0.3042,0.4580,0.7179,1.0342, & + 1.3485,1.6559,2.2102,0.0596/ + data (raod_lut(1,ib,4),ib=1,N_BANDS) /0.0766,0.1034,0.1323,0.1575,0.1932,0.2567,0.3068,0.4605,0.7196,1.0332, & + 1.3411,1.6407,2.1785,0.0608/ + data (raod_lut(1,ib,5),ib=1,N_BANDS) /0.0807,0.1083,0.1379,0.1635,0.1998,0.2639,0.3143,0.4677,0.7244,1.0305, & + 1.3227,1.6031,2.1006,0.0644/ + data (raod_lut(1,ib,6),ib=1,N_BANDS) /0.0884,0.1174,0.1482,0.1746,0.2118,0.2769,0.3277,0.4805,0.7328,1.0272, & + 1.2977,1.5525,1.9976,0.0712/ + data (raod_lut(1,ib,7),ib=1,N_BANDS) /0.1072,0.1391,0.1724,0.2006,0.2396,0.3066,0.3581,0.5087,0.7510,1.0231, & + 1.2622,1.4818,1.8565,0.0878/ + data (raod_lut(1,ib,8),ib=1,N_BANDS) /0.1286,0.1635,0.1991,0.2288,0.2693,0.3377,0.3895,0.5372,0.7686,1.0213, & + 1.2407,1.4394,1.7739,0.1072/ + + ! aer_type = 2 : urban (SF79) + data (raod_lut(2,ib,1),ib=1,N_BANDS) /0.1244,0.1587,0.1939,0.2233,0.2635,0.3317,0.3835,0.5318,0.7653,1.0344, & + 1.3155,1.5885,2.0706,0.1033/ + data (raod_lut(2,ib,2),ib=1,N_BANDS) /0.1159,0.1491,0.1834,0.2122,0.2518,0.3195,0.3712,0.5207,0.7585,1.0331, & + 1.3130,1.5833,2.0601,0.0956/ + data (raod_lut(2,ib,3),ib=1,N_BANDS) /0.1093,0.1416,0.1752,0.2035,0.2427,0.3099,0.3615,0.5118,0.7529,1.0316, & + 1.3083,1.5739,2.0408,0.0898/ + data (raod_lut(2,ib,4),ib=1,N_BANDS) /0.1062,0.1381,0.1712,0.1993,0.2382,0.3052,0.3567,0.5074,0.7501,1.0302, & + 1.3025,1.5620,2.0168,0.0870/ + data (raod_lut(2,ib,5),ib=1,N_BANDS) /0.1045,0.1361,0.1690,0.1970,0.2357,0.3025,0.3540,0.5049,0.7486,1.0271, & + 1.2864,1.5297,1.9518,0.0854/ + data (raod_lut(2,ib,6),ib=1,N_BANDS) /0.1065,0.1384,0.1716,0.1997,0.2386,0.3056,0.3571,0.5078,0.7504,1.0227, & + 1.2603,1.4780,1.8492,0.0872/ + data (raod_lut(2,ib,7),ib=1,N_BANDS) /0.1147,0.1478,0.1820,0.2107,0.2503,0.3179,0.3696,0.5192,0.7575,1.0146, & + 1.2116,1.3830,1.6658,0.0946/ + data (raod_lut(2,ib,8),ib=1,N_BANDS) /0.1247,0.1590,0.1943,0.2237,0.2639,0.3322,0.3840,0.5322,0.7656,1.0082, & + 1.1719,1.3075,1.5252,0.1036/ + + ! aer_type = 3 : maritime (SF79) + data (raod_lut(3,ib,1),ib=1,N_BANDS) /0.3053,0.3507,0.3932,0.4261,0.4681,0.5334,0.5797,0.6962,0.8583,1.0187, & + 1.1705,1.3049,1.5205,0.2748/ + data (raod_lut(3,ib,2),ib=1,N_BANDS) /0.3566,0.4023,0.4443,0.4765,0.5170,0.5792,0.6227,0.7298,0.8756,1.0162, & + 1.1472,1.2614,1.4415,0.3256/ + data (raod_lut(3,ib,3),ib=1,N_BANDS) /0.4359,0.4803,0.5203,0.5505,0.5879,0.6441,0.6828,0.7756,0.8985,1.0135, & + 1.1198,1.2109,1.3518,0.4051/ + data (raod_lut(3,ib,4),ib=1,N_BANDS) /0.5128,0.5544,0.5913,0.6187,0.6523,0.7020,0.7358,0.8149,0.9174,1.0115, & + 1.0995,1.1740,1.2875,0.4835/ + data (raod_lut(3,ib,5),ib=1,N_BANDS) /0.6479,0.6816,0.7108,0.7320,0.7575,0.7946,0.8193,0.8752,0.9455,1.0092, & + 1.0728,1.1263,1.2061,0.6236/ + data (raod_lut(3,ib,6),ib=1,N_BANDS) /0.7582,0.7831,0.8043,0.8196,0.8377,0.8636,0.8806,0.9184,0.9649,1.0080, & + 1.0564,1.0973,1.1576,0.7399/ + data (raod_lut(3,ib,7),ib=1,N_BANDS) /0.8482,0.8647,0.8785,0.8884,0.9000,0.9164,0.9272,0.9506,0.9789,1.0072, & + 1.0454,1.0780,1.1256,0.8360/ + data (raod_lut(3,ib,8),ib=1,N_BANDS) /0.8836,0.8965,0.9073,0.9149,0.9239,0.9365,0.9448,0.9626,0.9841,1.0069, & + 1.0415,1.0712,1.1145,0.8741/ + +! ++ Trude ; if 3D AOD, disaggreaget at all levels. + if (present(aod550_3d)) then + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + do kk = kts,kte + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,kk,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + tauaer3d(i,kk,j,ib)=0. + do jj=imin,imax + lj=1. + do k=imin,imax + if (k.ne.jj) lj=lj*(rh(i,kk,j)-rhs(k))/(rhs(jj)-rhs(k)) + end do + tauaer3d(i,kk,j,ib)=tauaer3d(i,kk,j,ib)+lj*raod_lut(aer_t,ib,jj)*aod550_3d(i,kk,j) + end do + end do + end do + end do + end do + else +! -- Trude + + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,kts,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + tauaer(i,j,ib)=0. + do jj=imin,imax + lj=1. + do k=imin,imax + if (k.ne.jj) lj=lj*(rh(i,kts,j)-rhs(k))/(rhs(jj)-rhs(k)) + end do + tauaer(i,j,ib)=tauaer(i,j,ib)+lj*raod_lut(aer_t,ib,jj)*aod550(i,j) + end do + end do + end do + end do + endif + +end subroutine calc_spectral_aod_rrtmg_sw + +subroutine calc_spectral_ssa_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type, & + ssaaer ) + implicit none + + ! constants + integer, parameter :: N_AER_TYPES=3 + integer, parameter :: N_RH=8 + integer, parameter :: N_BANDS=14 + integer, parameter :: N_INT_POINTS=4 + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte +!- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer:: aer_t + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type +!- end MPAS modifications (Laura D. Fowler/2018=04-09). + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: rh ! surface relative humidity + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: ssaaer ! aerosol single-scattering albedo at surface + + ! local variables + integer :: i,j,k,kk,ib,imax,imin,ii,jj + real :: rhs(N_RH),lj + real :: ssa_lut(N_AER_TYPES,N_BANDS,N_RH) + + ! relative humidity steps + data (rhs(i),i=1,8) /0.,50.,70.,80.,90.,95.,98.,99./ + + ! aer_type = 1 : rural (SF79) + data (ssa_lut(1,ib,1),ib=1,N_BANDS) /0.8730,0.6695,0.8530,0.8601,0.8365,0.7949,0.8113,0.8810,0.9305,0.9436, & + 0.9532,0.9395,0.8007,0.8634/ + data (ssa_lut(1,ib,2),ib=1,N_BANDS) /0.8428,0.6395,0.8571,0.8645,0.8408,0.8007,0.8167,0.8845,0.9326,0.9454, & + 0.9545,0.9416,0.8070,0.8589/ + data (ssa_lut(1,ib,3),ib=1,N_BANDS) /0.8000,0.6025,0.8668,0.8740,0.8503,0.8140,0.8309,0.8943,0.9370,0.9489, & + 0.9577,0.9451,0.8146,0.8548/ + data (ssa_lut(1,ib,4),ib=1,N_BANDS) /0.7298,0.5666,0.9030,0.9049,0.8863,0.8591,0.8701,0.9178,0.9524,0.9612, & + 0.9677,0.9576,0.8476,0.8578/ + data (ssa_lut(1,ib,5),ib=1,N_BANDS) /0.7010,0.5606,0.9312,0.9288,0.9183,0.9031,0.9112,0.9439,0.9677,0.9733, & + 0.9772,0.9699,0.8829,0.8590/ + data (ssa_lut(1,ib,6),ib=1,N_BANDS) /0.6933,0.5620,0.9465,0.9393,0.9346,0.9290,0.9332,0.9549,0.9738,0.9782, & + 0.9813,0.9750,0.8980,0.8594/ + data (ssa_lut(1,ib,7),ib=1,N_BANDS) /0.6842,0.5843,0.9597,0.9488,0.9462,0.9470,0.9518,0.9679,0.9808,0.9839, & + 0.9864,0.9794,0.9113,0.8648/ + data (ssa_lut(1,ib,8),ib=1,N_BANDS) /0.6786,0.5897,0.9658,0.9522,0.9530,0.9610,0.9651,0.9757,0.9852,0.9871, & + 0.9883,0.9835,0.9236,0.8618/ + + ! aer_type = 2: urban (SF79) + data (ssa_lut(2,ib,1),ib=1,N_BANDS) /0.4063,0.3663,0.4093,0.4205,0.4487,0.4912,0.5184,0.5743,0.6233,0.6392, & + 0.6442,0.6408,0.6105,0.4094/ + data (ssa_lut(2,ib,2),ib=1,N_BANDS) /0.4113,0.3654,0.4215,0.4330,0.4604,0.5022,0.5293,0.5848,0.6336,0.6493, & + 0.6542,0.6507,0.6205,0.4196/ + data (ssa_lut(2,ib,3),ib=1,N_BANDS) /0.4500,0.3781,0.4924,0.5050,0.5265,0.5713,0.6048,0.6274,0.6912,0.7714, & + 0.7308,0.7027,0.6772,0.4820/ + data (ssa_lut(2,ib,4),ib=1,N_BANDS) /0.5075,0.4139,0.5994,0.6127,0.6350,0.6669,0.6888,0.7333,0.7704,0.7809, & + 0.7821,0.7762,0.7454,0.5709/ + data (ssa_lut(2,ib,5),ib=1,N_BANDS) /0.5596,0.4570,0.7009,0.7118,0.7317,0.7583,0.7757,0.8093,0.8361,0.8422, & + 0.8406,0.8337,0.8036,0.6525/ + data (ssa_lut(2,ib,6),ib=1,N_BANDS) /0.6008,0.4971,0.7845,0.7906,0.8075,0.8290,0.8418,0.8649,0.8824,0.8849, & + 0.8815,0.8739,0.8455,0.7179/ + data (ssa_lut(2,ib,7),ib=1,N_BANDS) /0.6401,0.5407,0.8681,0.8664,0.8796,0.8968,0.9043,0.9159,0.9244,0.9234, & + 0.9182,0.9105,0.8849,0.7796/ + data (ssa_lut(2,ib,8),ib=1,N_BANDS) /0.6567,0.5618,0.9073,0.9077,0.9182,0.9279,0.9325,0.9398,0.9440,0.9413, & + 0.9355,0.9278,0.9039,0.8040/ + + ! aer_type = 3 : maritime (SF79) + data (ssa_lut(3,ib,1),ib=1,N_BANDS) /0.9697,0.9183,0.9749,0.9820,0.9780,0.9712,0.9708,0.9778,0.9831,0.9827, & + 0.9826,0.9723,0.8763,0.9716/ + data (ssa_lut(3,ib,2),ib=1,N_BANDS) /0.9070,0.8491,0.9730,0.9816,0.9804,0.9742,0.9738,0.9802,0.9847,0.9841, & + 0.9838,0.9744,0.8836,0.9546/ + data (ssa_lut(3,ib,3),ib=1,N_BANDS) /0.8378,0.7761,0.9797,0.9827,0.9829,0.9814,0.9812,0.9852,0.9882,0.9875, & + 0.9871,0.9791,0.9006,0.9348/ + data (ssa_lut(3,ib,4),ib=1,N_BANDS) /0.7866,0.7249,0.9890,0.9822,0.9856,0.9917,0.9924,0.9932,0.9943,0.9938, & + 0.9933,0.9887,0.9393,0.9204/ + data (ssa_lut(3,ib,5),ib=1,N_BANDS) /0.7761,0.7164,0.9959,0.9822,0.9834,0.9941,0.9955,0.9952,0.9960,0.9956, & + 0.9951,0.9922,0.9538,0.9152/ + data (ssa_lut(3,ib,6),ib=1,N_BANDS) /0.7671,0.7114,0.9902,0.9786,0.9838,0.9954,0.9970,0.9965,0.9971,0.9968, & + 0.9964,0.9943,0.9644,0.9158/ + data (ssa_lut(3,ib,7),ib=1,N_BANDS) /0.7551,0.7060,0.9890,0.9743,0.9807,0.9966,0.9989,0.9978,0.9982,0.9980, & + 0.9978,0.9964,0.9757,0.9122/ + data (ssa_lut(3,ib,8),ib=1,N_BANDS) /0.7439,0.7000,0.9870,0.9695,0.9769,0.9970,1.0000,0.9984,0.9988,0.9986, & + 0.9984,0.9975,0.9825,0.9076/ + + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + do k=kts,kte + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,k,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + ssaaer(i,k,j,ib)=0. + do jj=imin,imax + lj=1. + do kk=imin,imax + if (kk.ne.jj) lj=lj*(rh(i,k,j)-rhs(kk))/(rhs(jj)-rhs(kk)) + end do + ssaaer(i,k,j,ib)=ssaaer(i,k,j,ib)+lj*ssa_lut(aer_t,ib,jj) + end do + end do + end do + end do + end do +end subroutine calc_spectral_ssa_rrtmg_sw + +subroutine calc_spectral_asy_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type, & + asyaer ) + implicit none + + ! constants + integer, parameter :: N_AER_TYPES=3 + integer, parameter :: N_RH=8 + integer, parameter :: N_BANDS=14 + integer, parameter :: N_INT_POINTS=4 + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte +!- MPAS modifications: aer_type is a function of the land-sea mask, and set to 1 over land (or rural classification in WRF), +! and set to 0 over oceans (or maritime classification in WRF): +! integer, intent(in) :: aer_type + integer:: aer_t + integer, dimension(ims:ime,jms:jme), intent(in):: aer_type +!- end MPAS modifications (Laura D. Fowler/2018=04-09). + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: rh ! surface relative humidity + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: asyaer ! aerosol asymmetry parameter at surface + + ! local variables + integer :: i,j,k,kk,ib,imax,imin,ii,jj + real :: rhs(N_RH),lj + real :: asy_lut(N_AER_TYPES,N_BANDS,N_RH) + + ! relative humidity steps + data (rhs(i),i=1,8) /0.,50.,70.,80.,90.,95.,98.,99./ + + ! aer_type = 1 : rural (SF79) + data (asy_lut(1,ib,1),ib=1,N_BANDS) /0.7444,0.7711,0.7306,0.7103,0.6693,0.6267,0.6169,0.6207,0.6341,0.6497, & + 0.6630,0.6748,0.7208,0.7419/ + data (asy_lut(1,ib,2),ib=1,N_BANDS) /0.7444,0.7747,0.7314,0.7110,0.6711,0.6301,0.6210,0.6251,0.6392,0.6551, & + 0.6680,0.6799,0.7244,0.7436/ + data (asy_lut(1,ib,3),ib=1,N_BANDS) /0.7438,0.7845,0.7341,0.7137,0.6760,0.6381,0.6298,0.6350,0.6497,0.6657, & + 0.6790,0.6896,0.7300,0.7477/ + data (asy_lut(1,ib,4),ib=1,N_BANDS) /0.7336,0.7934,0.7425,0.7217,0.6925,0.6665,0.6616,0.6693,0.6857,0.7016, & + 0.7139,0.7218,0.7495,0.7574/ + data (asy_lut(1,ib,5),ib=1,N_BANDS) /0.7111,0.7865,0.7384,0.7198,0.6995,0.6864,0.6864,0.6987,0.7176,0.7326, & + 0.7427,0.7489,0.7644,0.7547/ + data (asy_lut(1,ib,6),ib=1,N_BANDS) /0.7009,0.7828,0.7366,0.7196,0.7034,0.6958,0.6979,0.7118,0.7310,0.7452, & + 0.7542,0.7593,0.7692,0.7522/ + data (asy_lut(1,ib,7),ib=1,N_BANDS) /0.7226,0.8127,0.7621,0.7434,0.7271,0.7231,0.7248,0.7351,0.7506,0.7622, & + 0.7688,0.7719,0.7756,0.7706/ + data (asy_lut(1,ib,8),ib=1,N_BANDS) /0.7296,0.8219,0.7651,0.7513,0.7404,0.7369,0.7386,0.7485,0.7626,0.7724, & + 0.7771,0.7789,0.7790,0.7760/ + + ! aer_type = 2: urban (SF79) + data (asy_lut(2,ib,1),ib=1,N_BANDS) /0.7399,0.7372,0.7110,0.6916,0.6582,0.6230,0.6147,0.6214,0.6412,0.6655, & + 0.6910,0.7124,0.7538,0.7395/ + data (asy_lut(2,ib,2),ib=1,N_BANDS) /0.7400,0.7419,0.7146,0.6952,0.6626,0.6287,0.6209,0.6280,0.6481,0.6723, & + 0.6974,0.7180,0.7575,0.7432/ + data (asy_lut(2,ib,3),ib=1,N_BANDS) /0.7363,0.7614,0.7303,0.7100,0.6815,0.6550,0.6498,0.6590,0.6802,0.7032, & + 0.7255,0.7430,0.7735,0.7580/ + data (asy_lut(2,ib,4),ib=1,N_BANDS) /0.7180,0.7701,0.7358,0.7163,0.6952,0.6807,0.6801,0.6935,0.7160,0.7370, & + 0.7553,0.7681,0.7862,0.7623/ + data (asy_lut(2,ib,5),ib=1,N_BANDS) /0.7013,0.7733,0.7374,0.7203,0.7057,0.7006,0.7035,0.7192,0.7415,0.7596, & + 0.7739,0.7827,0.7906,0.7596/ + data (asy_lut(2,ib,6),ib=1,N_BANDS) /0.6922,0.7773,0.7404,0.7264,0.7170,0.7179,0.7228,0.7389,0.7595,0.7746, & + 0.7851,0.7909,0.7918,0.7562/ + data (asy_lut(2,ib,7),ib=1,N_BANDS) /0.6928,0.7875,0.7491,0.7393,0.7345,0.7397,0.7455,0.7602,0.7773,0.7883, & + 0.7944,0.7970,0.7912,0.7555/ + data (asy_lut(2,ib,8),ib=1,N_BANDS) /0.7021,0.7989,0.7590,0.7512,0.7613,0.7746,0.7718,0.7727,0.7867,0.7953, & + 0.7988,0.7994,0.7906,0.7600/ + + ! aer_type = 3 : maritime (SF79) + data (asy_lut(3,ib,1),ib=1,N_BANDS) /0.6620,0.7011,0.7111,0.7068,0.6990,0.6918,0.6883,0.6827,0.6768,0.6773, & + 0.6863,0.6940,0.7245,0.6719/ + data (asy_lut(3,ib,2),ib=1,N_BANDS) /0.6880,0.7394,0.7297,0.7240,0.7162,0.7083,0.7038,0.6957,0.6908,0.6917, & + 0.6952,0.7035,0.7356,0.6977/ + data (asy_lut(3,ib,3),ib=1,N_BANDS) /0.7266,0.7970,0.7666,0.7593,0.7505,0.7427,0.7391,0.7293,0.7214,0.7210, & + 0.7212,0.7265,0.7519,0.7340/ + data (asy_lut(3,ib,4),ib=1,N_BANDS) /0.7683,0.8608,0.8120,0.8030,0.7826,0.7679,0.7713,0.7760,0.7723,0.7716, & + 0.7726,0.7767,0.7884,0.7768/ + data (asy_lut(3,ib,5),ib=1,N_BANDS) /0.7776,0.8727,0.8182,0.8083,0.7985,0.7939,0.7953,0.7913,0.7846,0.7870, & + 0.7899,0.7918,0.7969,0.7870/ + data (asy_lut(3,ib,6),ib=1,N_BANDS) /0.7878,0.8839,0.8231,0.8130,0.8050,0.7977,0.7945,0.7932,0.7955,0.7992, & + 0.8025,0.8035,0.8055,0.7956/ + data (asy_lut(3,ib,7),ib=1,N_BANDS) /0.8005,0.8957,0.8273,0.8179,0.8105,0.8035,0.8010,0.8030,0.8081,0.8108, & + 0.8143,0.8174,0.8174,0.8042/ + data (asy_lut(3,ib,8),ib=1,N_BANDS) /0.8104,0.9034,0.8294,0.8212,0.8144,0.8087,0.8077,0.8118,0.8175,0.8202, & + 0.8239,0.8265,0.8246,0.8095/ + + do j=jts,jte + do i=its,ite + !-- initialization of aerosol type: + aer_t = aer_type(i,j) + do k=kts,kte + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,k,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + asyaer(i,k,j,ib)=0. + do jj=imin,imax + lj=1. + do kk=imin,imax + if (kk.ne.jj) lj=lj*(rh(i,k,j)-rhs(kk))/(rhs(jj)-rhs(kk)) + end do + asyaer(i,k,j,ib)=asyaer(i,k,j,ib)+lj*asy_lut(aer_t,ib,jj) + end do + end do + end do + end do + end do +end subroutine calc_spectral_asy_rrtmg_sw + +subroutine aod_profiler(ht,dz8w,taod550,n_bands, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + aod550 & + ) + implicit none + + ! constants + real, parameter :: scale_height=2500. ! meters + + ! I/O variables + integer, intent(in) :: n_bands + integer, intent(in) :: ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte + real, dimension( ims:ime, jms:jme), intent(in) :: ht + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: dz8w + real, dimension( ims:ime, jms:jme, 1:n_bands), intent(in) :: taod550 + real, dimension( ims:ime, kms:kme, jms:jme, 1:n_bands ), intent(inout) :: aod550 + + ! local variables + real, dimension(its:ite,kts:kte) :: z2d,aod5502d + real, dimension(its:ite) :: htoa + real :: aod_scale + real :: aod_acum + integer :: i,j,k,nb + + ! input variables from driver are defined such as kms is sfc and + ! kme is toa. Equivalently, kts is sfc and kte is toa + do j=jts,jte + ! heigth profile + ! kts=surface, kte=toa + do i=its,ite + z2d(i,kts)=ht(i,j)+0.5*dz8w(i,kts,j) + do k=kts+1,kte + z2d(i,k)=z2d(i,k-1)+0.5*(dz8w(i,k-1,j)+dz8w(i,k,j)) + end do + htoa(i)=z2d(i,kte)+0.5*dz8w(i,kte,j) + end do + + do nb=1,n_bands + ! AOD exponential profile + do i=its,ite + aod_scale=taod550(i,j,nb)/(scale_height*(exp(-ht(i,j)/scale_height)-exp(-htoa(i)/scale_height))) + do k=kts,kte + aod550(i,k,j,nb)=aod_scale*dz8w(i,k,j)*exp(-z2d(i,k)/scale_height) + end do + end do + end do ! nb-loop + end do ! j-loop +end subroutine aod_profiler + +subroutine calc_relative_humidity(p,t3d,qv3d, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh ) + implicit none + + ! I/O variables + integer, intent(in) :: ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte + ! Naming convention: 8~at => p8w reads as "p-at-w" (w=full levels) + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: p, & ! pressure (Pa) + t3d, & ! temperature (K) + qv3d ! water vapor mixing ratio (kg/kg) + real, dimension(ims:ime, kms:kme, jms:jme), intent(inout) :: rh ! relative humidity at surface + + ! local variables + real :: tc,rv,es,e + integer :: i,j,k + + do j=jts,jte + do i=its,ite + do k=kts,kte ! only calculations at surface level + tc=t3d(i,k,j)-273.15 ! temperature (C) + rv=max(0.,qv3d(i,k,j)) ! water vapor mixing ration (kg kg-1) + es=6.112*exp((17.6*tc)/(tc+243.5)) ! saturation vapor pressure, hPa, Bolton (1980) + e =0.01*rv*p(i,k,j)/(rv+0.62197) ! vapor pressure, hPa, (ECMWF handouts, page 6, Atmosph. Thermdyn.) + ! rv=eps * e/(p-e) -> e=p * rv/(rv+eps), eps=0.62197 + rh(i,k,j)=min(99.,max(0.,100.*e/es)) ! relative humidity (%) + end do + end do + end do + +end subroutine calc_relative_humidity + +!================================================================================================================= + end module module_ra_rrtmg_sw_aerosols +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F index 544b802f37..eea050b236 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bem.F @@ -1,14 +1,20 @@ MODULE module_sf_bem -! ----------------------------------------------------------------------- -! Variables and constants used in the BEM module -! ----------------------------------------------------------------------- -#ifdef mpas -use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else -#define FATAL_ERROR(M) write(0,*) M ; stop +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif + +! ----------------------------------------------------------------------- +! Variables and constants used in the BEM module +! ----------------------------------------------------------------------- real emins !emissivity of the internal walls parameter (emins=0.9) @@ -27,6 +33,7 @@ MODULE module_sf_bem real hum_rat !power of the A.C. drying/moistening the indoor air [(Kg/kg)/s] parameter(hum_rat=1.e-06) + real,parameter :: effpv=0.19 ! Efficiency of PV panels installed at the roofs, typical values [0.10,0.15] CONTAINS @@ -35,16 +42,21 @@ MODULE module_sf_bem subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & nwal,nflo,nrof,ngrd,hswalout,gswal, & - hswinout,hsrof,gsrof, & + hswinout,hsrof,lsrof,gsrof,hspv, & latent,sigma,albwal,albwin,albrof, & emrof,emwal,emwin,rswal,rlwal,rair,cp, & rhoout,tout,humout,press, & - rs,rl,dzwal,cswal,kwal,pwin,cop,beta,sw_cond, & + rs,swddif,rl,dzwal,cswal,kwal,pwin,cop,beta,sw_cond, & timeon,timeoff,targtemp,gaptemp,targhum,gaphum, & - perflo,hsesf,hsequip,dzflo, & + perflo,gr_frac_roof,pv_frac_roof,gr_flag, & + uout,vout, & + hsesf,hsequip,dzflo, & csflo,kflo,dzgrd,csgrd,kgrd,dzrof,csrof, & krof,tlev,shumlev,twal,twin,tflo,tgrd,trof, & - hsout,hlout,consump,hsvent,hlvent) + hsout,hlout,consump,eppv,tpv,hsvent,hlvent,hfgr,& + tr_av,tpv_print,sfpv,sfr_indoor) + + ! --------------------------------------------------------------------- @@ -97,7 +109,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real dt !time step [s] - integer nzcanm !Maximum number of vertical levels in the urban grid + integer nzcanm !Maximum number of vertical levels in the urban grid integer nlev !number of floors in the building integer nwal !number of levels inside the wall integer nrof !number of levels inside the roof @@ -127,6 +139,11 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real, intent(in) :: targhum ! Target humidity of A/C systems real, intent(in) :: gaphum ! Comfort range of specific humidity real, intent(in) :: perflo ! Peak number of occupants per unit floor area + real gr_frac_roof + real pv_frac_roof + integer gr_flag + real uout(nzcanm) + real vout(nzcanm) real, intent(in) :: hsesf ! real, intent(in) :: hsequip(24) ! @@ -145,11 +162,12 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real dzflo(nflo) !Layer sizes of floors [m] real dzrof(nrof) !Layer sizes of roof [m] real dzgrd(ngrd) !Layer sizes of ground [m] - + real tpv + real tr_av real latent !latent heat of evaporation [J/Kg] - - real rs !external short wave radiation [W/m2] + real swddif + real rs !external short wave radiation [W/m2] real rl !external long wave radiation [W/m2] real rswal(4,nzcanm) !short wave radiation reaching the exterior walls [W/m2] real rlwal(4,nzcanm) !long wave radiation reaching the walls [W/m2] @@ -161,11 +179,11 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real hswalout(4,nzcanm) !outside walls sensible heat flux [W/m2] real hswinout(4,nzcanm) !outside window sensible heat flux [W/m2] real hsrof !Sensible heat flux at the roof [W/m2] - - real rair !ideal gas constant [J.kg-1.K-1] + real lsrof + real rair !ideal gas constant [J.kg-1.K-1] real sigma !parameter (wall is not black body) [W/m2.K4] real cp !specific heat of air [J/kg.K] - + real hfgr !Green roof heat flux !Input-Output !------------ @@ -181,9 +199,11 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real consump(nzcanm) !Consumption for the a.c. in each floor [W] real hsvent(nzcanm) !sensible heat generated by natural ventilation [W] real hlvent(nzcanm) !latent heat generated by natural ventilation [W] - real gsrof !heat flux flowing inside the roof [W/m] - real gswal(4,nzcanm) !heat flux flowing inside the floors [W/m] - + real gsrof !heat flux flowing inside the roof [W/m2] + real hspv !Sensible heat flux at the roof from the PV panels [W/m2] + real gswal(4,nzcanm) !heat flux flowing inside the floors [W/m2] + real eppv !Electricity production of PV panels [W] + real sfr_indoor,sfpv,tpv_print ! Local: ! ----- integer swwal !swich for the physical coefficients calculation @@ -234,10 +254,13 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & real hsoutbuild !Total sensible heat ejected into the atmosphere[W] !by the air conditioning system and per building real nhourday !number of hours from midnight, local time + real hfgrd !Dummy variable to assign hfgr=0 to walls, windows and ground + +! + parameter(hfgrd=0) !-------------------------------------------- !Initialization !-------------------------------------------- - do ilev=1,nzcanm hseqocc(ilev)=0. hleqocc(ilev)=0. @@ -401,11 +424,15 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & end do ! ivw end do ! ilev -!Roof - - call radfluxs(radflux,albrof,rs,emrof,rl,sigma,trof(nrof)) - - hrrof=radflux +!Roof and PV panels + + if (pv_frac_roof.eq.0.) then + call radfluxs(radflux,albrof,rs,emrof,rl,sigma,tr_av) + hrrof=radflux + else + call radfluxspv(nzcanm,nlev,albrof,rs,swddif,emrof,rl,tr_av,tout,sigma,radflux,pv_frac_roof,tpv) + hrrof=radflux + endif !Internal walls for intermediate rooms @@ -548,7 +575,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & !Vertical fluxes for windows do ilev=1,nlev - + do ivw=1,4 call hsinsflux (2,1,tlev(ilev),twin(ivw,ilev),hs) @@ -594,7 +621,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & call hsinsflux (1,2,tlev(nlev),trof(1),hs) hswalins(6,nlev)=hs - + sfr_indoor= hswalins(6,nlev) else ! Bottom<--->Top call hsinsflux (1,2,tlev(1),tgrd(ngrd),hs) @@ -606,7 +633,15 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & hswalins(6,nlev)=hs end if +!! +!! Calculation of the sensible heat fluxes from the PV panels & electricity producti + + if(pv_frac_roof.gt.0)then + call hsfluxpv(nzcanm,nlev,bl,bw,albrof,rs,swddif,emrof,rl,tr_av,tout,sigma,hspv,eppv,pv_frac_roof,uout,vout,tpv,dt) + sfpv=hspv + tpv_print=tpv + endif !Calculation of the temperature for the different surfaces ! -------------------------------------------------------- @@ -624,7 +659,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & do iwal=1,nwal twal1D(iwal)=twal(ivw,iwal,ilev) end do - + call wall(swwal,nwal,dt,dzwal,kwal,cswal,htot,twal1D) do iwal=1,nwal @@ -695,19 +730,25 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & swwal=1 htot(1)=hswalins(6,nlev)+hrwalins(6,nlev) - htot(2)=hsrof+hrrof + htot(2)=hsrof+hrrof+lsrof gsrof=htot(2) do irof=1,nrof trof1D(irof)=trof(irof) - end do - - call wall(swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D) - + + end do + + if(gr_flag.eq.1)then + call wall_gr(hfgr,gr_frac_roof,swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D) + else + call wall(swwal,nrof,dt,dzrof,krof,csrof,htot,trof1D) + endif do irof=1,nrof trof(irof)=trof1D(irof) - end do + + end do + ! Calculation of the heat fluxes and of the temperature of the rooms ! ------------------------------------------------------------------ @@ -728,6 +769,7 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & call fluxvent(cpint,rhoint,vollev,tlev(ilev),tout(ilev), & latent,humout(ilev),rhoout(ilev),shumlev(ilev),& beta,hsvent(ilev),hlvent(ilev)) + !Calculation of the heat generated by conduction @@ -782,11 +824,95 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev, & return end subroutine BEM - +!====6=8===============================================================72 +!====6=8===============================================================72 + subroutine hsfluxpv(nz,n,bl,bw,albr,rs,swddif,emr,rl,tr,tair,sigma,hspv,eppv,pv_frac_roof,uout,vout,tpv,dt) +! + implicit none +! +! Input variables +! + integer,intent(in) :: nz !Maximum number of vertical levels in the urban grid + real,intent(in) :: bl !Building length [m] + real,intent(in) :: bw !Building width [m] + real,intent(in) :: albr !albedo of the roof (ext.) + real,intent(in) :: emr !emissivity of the roof (ext.) + real,intent(in) :: rs !external short wave radiation [W/m2] + real,intent(in) :: rl !external long wave radiation [W/m2] + real,intent(in) :: tr !roof surface temperature [K] + real,intent(in) :: pv_frac_roof ! fraction of PV [] + real,intent(in) :: sigma !Stefan-Boltzmann constant [W/m2.K4] + real,intent(in),dimension(1:nz) :: tair !external temperature [K] + integer,intent(in) :: n !number of floors in the building + real,intent(in), dimension(1:nz) :: uout + real,intent(in), dimension(1:nz) :: vout + real,intent(in) :: dt + real,intent(in) :: swddif +! Output variables +! + real,intent(inout) :: hspv ! Sensible heat flux from the PV panels to the atmosphere [W/m2] + real,intent(inout) :: eppv ! Electricity production from PV panels [W] + real,intent(inout) :: tpv !Temperature of the PV panels [K] +! +! Local variables +! + real,parameter :: albpv=0.11 ! albedo of the PV panels + real,parameter :: empv_down=0.95 ! emissivity of the PV panels + real,parameter :: empv_up=0.79 + real, parameter :: T_amb=25 + real, parameter :: tiltangle=0. + real, parameter :: a=3.8 + real, parameter :: b=6.9 + + real, parameter :: r1=2330. + real, parameter :: r2=1200. + real, parameter :: r3=3000. + real, parameter :: c1=677. + real, parameter :: c2=1250. + real, parameter :: c3=500. + real, parameter :: d1=0.0003 + real, parameter :: d2=0.0005 + real, parameter :: d3=0.003 + real, parameter :: F12=1. + real :: lwuppv !Long-wave emitted by the PV panels to the sky [W/m2] + real :: lwdwr !Long-wave incoming radiation on the roof [W/m2] + real :: lwupr !Long-wave coming up from the roof intercepted by the PV panels [W/m2] + real :: enerpv !Energy produced by PV panels [W/m2] + real :: hc + real :: sw_d + real :: lw_d + real :: lwpv_out + real :: tpv_new + real :: hdown + real :: hup + real :: deltat + real :: uroof + real :: hrad + real :: Cm + real :: hf + Cm=r1*c1*d1+r2*c2*d2+r3*c3*d3 + hrad=sigma/((1-empv_down)/empv_down+1/F12+(1-emr)/emr) + uroof=(uout(n+1)**2+vout(n+1)**2)**0.5 + deltat=tpv-tair(n+1) + hf=2.5*(40./100.*uroof)**(0.5) + hc=9.842*abs(deltat)**(1./3.)/(7.283-abs(cos(tiltangle))) + hup=sqrt(hc**2.+(hf)**2.) + hc=1.810*abs(deltat)**(1./3.)/(1.382+abs(cos(tiltangle))) + hdown=sqrt(hc**2.+(hf)**2.) + enerpv=effpv*rs*min(1.,1.-0.005*(tpv-(T_amb+273.15))) + sw_d=(1-albpv)*(rs) + lw_d=empv_up*rl + lwpv_out=empv_up*sigma*tpv**4. + lwupr=hrad*(tr**4-tpv**4.) + hspv=(hup+hdown)*(tpv-tair(n+1)) + tpv=tpv+(sw_d+lw_d-lwpv_out+lwupr-hspv-enerpv)/Cm*dt + eppv=enerpv*pv_frac_roof*bl*bw + return + end subroutine hsfluxpv !====6=8===============================================================72 !====6=8===============================================================72 - subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) + subroutine wall_gr(hfgr,gr_frac_roof,swwall,nz,dt,dz,k,cs,flux,temp) !______________________________________________________________________ @@ -826,12 +952,16 @@ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) !Input: !----- + real hfgr !Green roof heat flux + real gr_frac_roof !Green roof fraction + integer nz !Number of layers inside the material real dt !Time step real dz(nz) !Layer sizes [m] real cs(nz) !Specific heat of the material [J/(m3.K)] real k(nz+1) !Thermal conductivity in each layers (face) [W/(m.K)] real flux(2) !Internal and external flux terms. + !Input-Output: !------------- @@ -875,25 +1005,140 @@ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) a(-1,1)=0. a(0,1)=1+k2(1) a(1,1)=-k2(1) - b(1)=temp(1)+flux(1)*kc(1) -!! -!!We can fixed the internal temperature -!! -!! a(-1,1)=0. -!! a(0,1)=1 -!! a(1,1)=0. -!! -!! b(1)=temp(1) -!! -!Computation of the internal values (iz=2,...,n-1) of A and B: + do iz=2,nz-1 + a(-1,iz)=-k1(iz) + if(iz.eq.5)then + a(-1,iz)=-k1(iz) + a(0,iz)=1+k1(iz)+(1-gr_frac_roof)*k2(iz) + b(iz)=temp(iz)+(gr_frac_roof*hfgr*dt)/dz(iz) + a(1,iz)=-k2(iz)*(1-gr_frac_roof) + else + a(0,iz)=1.+k1(iz)+k2(iz) + b(iz)=temp(iz) + a(1,iz)=-k2(iz) + endif + + + end do + +!Computation of the external value (iz=n) of A and B: + + a(-1,nz)=-k1(nz) + a(0,nz)=1.+k1(nz) + a(1,nz)=0. + b(nz)=temp(nz)+kc(nz)*flux(2) + +!Resolution of the system A*T(n+1)=B + + call tridia(nz,a,b,temp) + + + return + end subroutine wall_gr + +!====6=8===============================================================72 +!====6=8===============================================================72 + + + subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) + +!______________________________________________________________________ + +!The aim of this subroutine is to solve the 1D heat fiffusion equation +!for roof, walls and streets: +! +! dT/dt=d/dz[K*dT/dz] where: +! +! -T is the surface temperature(wall, street, roof) +! -Kz is the heat diffusivity inside the material. +! +!The resolution is done implicitly with a FV discretisation along the +!different layers of the material: + +! ____________________________ +! n * +! * +! * +! ____________________________ +! i+2 +! I+1 +! ____________________________ +! i+1 +! I ==> [T(I,n+1)-T(I,n)]/DT= +! ____________________________ [F(i+1)-F(i)]/DZI +! i +! I-1 ==> A*T(n+1)=B where: +! ____________________________ +! i-1 * * A is a TRIDIAGONAL matrix. +! * * B=T(n)+S takes into account the sources. +! * +! 1 ____________________________ + +!________________________________________________________________ + + implicit none + +!Input: +!----- + integer nz !Number of layers inside the material + real dt !Time step + real dz(nz) !Layer sizes [m] + real cs(nz) !Specific heat of the material [J/(m3.K)] + real k(nz+1) !Thermal conductivity in each layers (face) [W/(m.K)] + real flux(2) !Internal and external flux terms. + + +!Input-Output: +!------------- + + integer swwall !swich for the physical coefficients calculation + real temp(nz) !Temperature at each layer + +!Local: +!----- + + real a(-1:1,nz) ! a(-1,*) lower diagonal A(i,i-1) + ! a(0,*) principal diagonal A(i,i) + ! a(1,*) upper diagonal A(i,i+1). + + real b(nz) !Coefficients of the second term. + real k1(20) + real k2(20) + real kc(20) + save k1,k2,kc + integer iz + +!________________________________________________________________ +! +!Calculation of the coefficients + + if (swwall.eq.1) then + + if (nz.gt.20) then + write(*,*) 'number of layers in the walls/roofs too big ',nz + write(*,*) 'please decrease under of',20 + stop + endif + + call wall_coeff(nz,dt,dz,cs,k,k1,k2,kc) + swwall=0 + + end if + +!Computation of the first value (iz=1) of A and B: + + a(-1,1)=0. + a(0,1)=1+k2(1) + a(1,1)=-k2(1) + b(1)=temp(1)+flux(1)*kc(1) do iz=2,nz-1 - a(-1,iz)=-k1(iz) - a(0,iz)=1+k1(iz)+k2(iz) - a(1,iz)=-k2(iz) - b(iz)=temp(iz) + a(-1,iz)=-k1(iz) + a(0,iz)=1+k1(iz)+k2(iz) + b(iz)=temp(iz) + a(1,iz)=-k2(iz) end do !Computation of the external value (iz=n) of A and B: @@ -901,12 +1146,12 @@ subroutine wall(swwall,nz,dt,dz,k,cs,flux,temp) a(-1,nz)=-k1(nz) a(0,nz)=1+k1(nz) a(1,nz)=0. - b(nz)=temp(nz)+flux(2)*kc(nz) - + !Resolution of the system A*T(n+1)=B call tridia(nz,a,b,temp) + return end subroutine wall @@ -983,7 +1228,7 @@ subroutine hsinsflux(swsurf,swwin,tin,tw,hsins) !Input !---- integer swsurf !swich for the type of surface (horizontal/vertical) - integer swwin !swich for the type of surface (window/wall) + integer swwin !swich for the type of surface (window/wall) real tin !Inside temperature [K] real tw !Internal wall temperature [K] @@ -993,7 +1238,7 @@ subroutine hsinsflux(swsurf,swwin,tin,tw,hsins) real hsins !internal sensible heat flux [W/m2] !Local !----- - real hc !heat conduction coefficient [W/C.m2] + real hc !heat conduction coefficient [W/\B0C.m2] !-------------------------------------------------------------------- if (swsurf.eq.2) then !vertical surface @@ -1031,7 +1276,7 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,& real albwin !albedo of the windows real albwal !albedo of the internal wall real rswal(4) !incoming short wave radiation [W/m2] - real surwal(6) !surface of the indoor walls [m2] + real surwal(6) !surface of the indoor walls [m2] real bw,bl !width of the walls [m] real zw !height of the wall [m] real pwin !window proportion @@ -1043,8 +1288,8 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,& !Local !----- real transmit !transmittance of the direct/diffused radiation - real rstr !solar radiation transmitted through the windows - real surtotwal !total indoor surface of the walls in the room + real rstr !solar radiation transmitted through the windows + real surtotwal !total indoor surface of the walls in the room integer iw real b(6) !second member for the system real a(6,6) !matrix for the system @@ -1061,7 +1306,7 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,& enddo !We suppose that the radiation is spread isotropically within the -!room when it passes through the windows, so the flux [W/m] in every +!room when it passes through the windows, so the flux [W/m2] in every !wall is: surtotwal=0. @@ -1315,8 +1560,8 @@ subroutine algebra_long(emwal,emwin,sigma,twalint,twinint,& real zw !height of the wall real fprl_int !view factor real fnrm_int !view factor - real fnrm_intx !view factor - real fnrm_inty !view factor + real fnrm_intx !view factor + real fnrm_inty !view factor !Output !------ @@ -1329,7 +1574,7 @@ subroutine algebra_long(emwal,emwin,sigma,twalint,twinint,& real b_wind(6) real emwal_av !averadge emissivity of the wall real emwin_av !averadge emissivity of the window - real em_av !averadge emissivity + real em_av !averadge emissivity real twal_int(6) !twalint real twin(4) !twinint !------------------------------------------------------------------ @@ -1669,7 +1914,7 @@ subroutine phiequ(nhourday,hsesf,hsequip,hsequ) !Output !------ - real hsequ !sensible heat gain from equipment [Wm2] + real hsequ !sensible heat gain from equipment [Wm\AF2] !--------------------------------------------------------------------- @@ -2299,7 +2544,52 @@ subroutine radfluxs(radflux,alb,rs,em,rl,sigma,twal) return end subroutine radfluxs - +!====6=8===============================================================72 +!====6=8===============================================================72 + subroutine radfluxspv(nz,n,alb,rs,swddif,em,rl,twal,tair,sigma,radflux,pv_frac_roof,tpv) +! + implicit none +! +! This routine calculates the radiative fluxes at the surfaces +! +! Integer and real kinds +! +! integer, parameter :: kind_im = selected_int_kind(6) ! 4 byte integer +! integer, parameter :: kind_rb = selected_real_kind(12) ! 8 byte real +! +! Input Variables +! + integer,intent(in) :: nz !Maximum number of vertical levels in the urban grid + real,intent(in) :: alb !albedo of the surface + real,intent(in) :: rs !shortwave radiation [W m-2] + real,intent(in) :: swddif + real,intent(in) :: em !emissivity of the surface + real,intent(in) :: rl !longwave radiation [W m-2] + real,intent(in) :: twal !surface temperature [K] + real,intent(in) :: sigma !Stefan-Boltzmann constant [W/m2.K4] + real,intent(in) :: tpv !Stefan-Boltzmann constant [W/m2.K4] + real,intent(in),dimension(1:nz) :: tair !external temperature [K] + integer,intent(in) :: n !number of floors in the building + real, intent(in) :: pv_frac_roof ! + real :: empv + real :: hrad + real :: F12 +! Output variables +! + real,intent(inout) :: radflux !radiative flux at the surface [W m-2] +! +! Local variables + F12=1. + empv=0.95 + hrad=sigma/((1-empv)/empv+1/F12+(1-em)/em) + if ((n+1).gt.nz) then + write(*,*) 'Increase maximum number of vertical levels in the urban grid' + stop + endif + radflux=(1.-alb)*(1.-pv_frac_roof)*rs+em*(1.-pv_frac_roof)*rl+pv_frac_roof*hrad*(tpv**4-twal**4)- & + em*sigma*(1.-pv_frac_roof)*twal**4 + return + end subroutine radfluxspv !====6=8==============================================================72 !====6=8==============================================================72 ! diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F index 9434dc8fac..a0f2bdf645 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep.F @@ -1,31 +1,35 @@ MODULE module_sf_bep -#ifdef mpas +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else -#define FATAL_ERROR(M) write(0,*) M ; stop -#endif - +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) !USE module_model_constants +#endif USE module_sf_urban + USE module_bep_bem_helper, ONLY: nurbm ! SGClarke 09/11/2008 ! Access urban_param.tbl values through calling urban_param_init in module_physics_init ! for CASE (BEPSCHEME) select sf_urban_physics ! - ! ----------------------------------------------------------------------- +! ----------------------------------------------------------------------- ! Dimension for the array used in the BEP module ! ----------------------------------------------------------------------- - - integer nurbm ! Maximum number of urban classes - parameter (nurbm=3) + integer nurbmax ! Maximum number of urban classes + parameter (nurbmax=11) integer ndm ! Maximum number of street directions parameter (ndm=2) integer nz_um ! Maximum number of vertical levels in the urban grid - parameter(nz_um=13) + parameter(nz_um=18) integer ng_u ! Number of grid levels in the ground parameter (ng_u=10) @@ -64,11 +68,15 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat, & declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, & + num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & a_u,a_v,a_t,a_e,b_u,b_v, & - b_t,b_e,dlg,dl_u,sf,vl, & + b_t,b_e,b_q,dlg,dl_u,sf,vl, & rl_up,rs_abs,emiss,grdflx_urb, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -106,15 +114,30 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & REAL, INTENT(IN) :: DECLIN_URB REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D - INTEGER, INTENT(IN ) :: num_urban_layers - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: num_urban_hi + REAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d + REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lp_urb2d + REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lb_urb2d + REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: hgt_urb2d + ! integer nx,ny,nz ! Number of points in the mesocsale grid real z(ims:ime,kms:kme,jms:jme) ! Vertical coordinates REAL, INTENT(IN ):: DT ! Time step @@ -137,68 +160,99 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real b_v(ims:ime,kms:kme,jms:jme) ! Explicit component for the momemtum in Y-direction (center) real b_t(ims:ime,kms:kme,jms:jme) ! Explicit component for the temperature real b_e(ims:ime,kms:kme,jms:jme) ! Explicit component for the TKE + real b_q(ims:ime,kms:kme,jms:jme) ! Explicit component for the humidity real dlg(ims:ime,kms:kme,jms:jme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u(ims:ime,kms:kme,jms:jme) ! Length scale (lb in formula (22) ofthe BLM paper). ! urban surface and volumes real sf(ims:ime,kms:kme,jms:jme) ! surface of the urban grid cells real vl(ims:ime,kms:kme,jms:jme) ! volume of the urban grid cells ! urban fluxes - real rl_up(ims:ime,jms:jme) ! upward long wave radiation - real rs_abs(ims:ime,jms:jme) ! absorbed short wave radiation - real emiss(ims:ime,jms:jme) ! emissivity averaged for urban surfaces - real grdflx_urb(ims:ime,jms:jme) ! ground heat flux for urban areas + real rl_up(its:ite,jts:jte) ! upward long wave radiation + real rs_abs(its:ite,jts:jte) ! absorbed short wave radiation + real emiss(its:ite,jts:jte) ! emissivity averaged for urban surfaces + real grdflx_urb(its:ite,jts:jte) ! ground heat flux for urban areas !------------------------------------------------------------------------ ! Local !------------------------------------------------------------------------ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + real hi_urb(its:ite,1:nz_um,jts:jte) ! Height histograms of buildings + real hi_urb1D(nz_um) ! Height histograms of buildings + real hb_u(nz_um) ! Bulding's heights + real ss_urb(nz_um) ! Probability that a building has an height equal to z + real pb_urb(nz_um) ! Probability that a building has an height greater or equal to z + integer nz_urb(nurbmax) ! Number of layer in the urban grid + integer nzurban(nurbmax) + ! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] - real twini_u(nurbm) ! Initial temperature inside the building's wall [K] - real trini_u(nurbm) ! Initial temperature inside the building's roof [K] - real tgini_u(nurbm) ! Initial road temperature + real alag_u(nurbmax) ! Ground thermal diffusivity [m^2 s^-1] + real alaw_u(nurbmax) ! Wall thermal diffusivity [m^2 s^-1] + real alar_u(nurbmax) ! Roof thermal diffusivity [m^2 s^-1] + real csg_u(nurbmax) ! Specific heat of the ground material [J m^3 K^-1] + real csw_u(nurbmax) ! Specific heat of the wall material [J m^3 K^-1] + real csr_u(nurbmax) ! Specific heat of the roof material [J m^3 K^-1] + real twini_u(nurbmax) ! Initial temperature inside the building's wall [K] + real trini_u(nurbmax) ! Initial temperature inside the building's roof [K] + real tgini_u(nurbmax) ! Initial road temperature +! +! Building materials +! + real csg(ng_u) ! Specific heat of the ground material [J m^3 K^-1] + real csr(nwr_u) ! Specific heat of the roof material [J m^3 K^-1] + real csw(nwr_u) ! Specific heat of the wall material [J m^3 K^-1] + real alag(ng_u) ! Ground thermal diffusivity [m^2 s^-1] + real alaw(nwr_u) ! Wall thermal diffusivity [m^2 s^-1] + real alar(nwr_u) ! Roof thermal diffusivity [m^2 s^-1] ! ! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation ! -! Radiation paramters - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof - -! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave +! Radiation parameters + real albg_u(nurbmax) ! Albedo of the ground + real albw_u(nurbmax) ! Albedo of the wall + real albr_u(nurbmax) ! Albedo of the roof + real emg_u(nurbmax) ! Emissivity of ground + real emw_u(nurbmax) ! Emissivity of wall + real emr_u(nurbmax) ! Emissivity of roof + +! fww_u,fwg_u,fgw_u,fsw_u,fsg_u are the view factors used to compute the long wave ! and the short wave radation. - real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall - real fwg(nz_um,ndm,nurbm) ! from wall to ground - real fgw(nz_um,ndm,nurbm) ! from ground to wall - real fsw(nz_um,ndm,nurbm) ! from sky to wall - real fws(nz_um,ndm,nurbm) ! from sky to wall - real fsg(ndm,nurbm) ! from sky to ground + real fww_u(nz_um,nz_um,ndm,nurbmax) ! from wall to wall + real fwg_u(nz_um,ndm,nurbmax) ! from wall to ground + real fgw_u(nz_um,ndm,nurbmax) ! from ground to wall + real fsw_u(nz_um,ndm,nurbmax) ! from sky to wall + real fws_u(nz_um,ndm,nurbmax) ! from sky to wall + real fsg_u(ndm,nurbmax) ! from sky to ground ! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + real z0g_u(nurbmax) ! The ground's roughness length + real z0r_u(nurbmax) ! The roof's roughness length -! Street parameters - integer nd_u(nurbm) ! Number of street direction for each urban class - real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction - real ws_u(ndm,nurbm) ! Street width - real bs_u(ndm,nurbm) ! Building width - real h_b(nz_um,nurbm) ! Bulding's heights - real d_b(nz_um,nurbm) ! Probability that a building has an height h_b - real ss_u(nz_um,nurbm) ! Probability that a building has an height equal to z - real pb_u(nz_um,nurbm) ! Probability that a building has an height greater or equal to z +! Roughness parameters + real z0(ndm,nz_um) ! Roughness lengths "profiles" +! Street parameters + integer nd_u(nurbmax) ! Number of street direction for each urban class + real strd_u(ndm,nurbmax) ! Street length (fix to greater value to the horizontal length of the cells) + real drst_u(ndm,nurbmax) ! Street direction + real ws_u(ndm,nurbmax) ! Street width + real bs_u(ndm,nurbmax) ! Building width + real h_b(nz_um,nurbmax) ! Bulding's heights + real d_b(nz_um,nurbmax) ! Probability that a building has an height h_b + real ss_u(nz_um,nurbmax) ! Probability that a building has an height equal to z + real pb_u(nz_um,nurbmax) ! Probability that a building has an height greater or equal to z +! +! Street parameters +! + real bs(ndm) ! Building width + real ws(ndm) ! Street width + real drst(ndm) ! street directions + real strd(ndm) ! Street lengths + real ss(nz_um) ! Probability to have a building with height h + real pb(nz_um) ! Probability to have a building with an height equal ! Grid parameters - integer nz_u(nurbm) ! Number of layer in the urban grid + + integer nz_u(nurbmax) ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels @@ -236,7 +290,6 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real b_e1D(kms:kme) ! Explicit component of the TKE sources or sinks real dlg1D(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u1D(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper) - real tsk1D ! Average of the road surface temperatures real time_bep ! arrays used to collapse indexes integer ind_zwd(nz_um,nwr_u,ndm) @@ -246,16 +299,16 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & integer ix,iy,iz,iurb,id,iz_u,iw,ig,ir,ix1,iy1,k integer it, nint integer iii - real time_h,tempo,shtot + real time_h,tempo logical first character(len=80) :: text data first/.true./ save first,time_bep save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u + albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & + z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & + nz_u,z_u !------------------------------------------------------------------------ ! Calculation of the momentum, heat and turbulent kinetic fluxes @@ -268,8 +321,8 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & !------------------------------------------------------------------------ !prepare the arrays to collapse indexes - if(num_urban_layers.lt.nz_um*ndm*nwr_u)then - write(*,*)'num_urban_layers too small, please increase to at least ', nz_um*ndm*nwr_u + if(urban_map_zrd.lt.nz_um*ndm*nwr_u)then + write(*,*)'urban_map_zrd too small, please increase to at least ', nz_um*ndm*nwr_u stop endif iii=0 @@ -297,38 +350,73 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_zd(iz_u,id)=iii enddo enddo + + if (num_urban_hi.ge.nz_um)then + write(*,*)'nz_um too small, please increase to at least ', num_urban_hi+1 + stop + endif + + do ix=its,ite + do iy=jts,jte + do iz_u=1,nz_um + hi_urb(ix,iz_u,iy)=0. + enddo + enddo + enddo + do ix=its,ite do iy=jts,jte z(ix,kts,iy)=0. do iz=kts+1,kte+1 z(ix,iz,iy)=z(ix,iz-1,iy)+dz8w(ix,iz-1,iy) - enddo + enddo !iz + do iz_u=1,num_urban_hi + hi_urb(ix,iz_u,iy)= hi_urb2d(ix,iz_u,iy) + enddo !iz_u enddo enddo + if (first) then ! True only on first call + call init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,emg_u,emw_u,& emr_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b) ! Initialisation of the urban parameters and calculation of the view factors - call icBEP(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & - twini_u,trini_u) - - first=.false. + + call icBEP(nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) + + first=.false. endif ! first - + do ix=its,ite do iy=jts,jte - if (FRC_URB2D(ix,iy).gt.0.) then ! Calling BEP only for existing urban classes. - - iurb=UTYPE_URB2D(ix,iy) + if (FRC_URB2D(ix,iy).gt.0.) then ! Calling BEP only for existing urban classes. + iurb=UTYPE_URB2D(ix,iy) + + hi_urb1D=0. + do iz_u=1,nz_um + hi_urb1D(iz_u)=hi_urb(ix,iz_u,iy) + enddo + + call icBEPHI_XY(hb_u,hi_urb1D,ss_urb,pb_urb, & + nz_urb(iurb),z_u) + + call param(iurb,nz_u(iurb),nz_urb(iurb),nzurban(iurb), & + nd_u(iurb),csg_u,csg,alag_u,alag,csr_u,csr, & + alar_u,alar,csw_u,csw,alaw_u,alaw, & + ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, & + strd_u,strd,drst_u,drst,ss_u,ss_urb,ss,pb_u, & + pb_urb,pb,lp_urb2d(ix,iy), & + lb_urb2d(ix,iy),hgt_urb2d(ix,iy),FRC_URB2D(ix,iy)) +! +!We compute the view factors in the icBEP_XY routine +! + + call icBEP_XY(iurb,fww_u,fwg_u,fgw_u,fsw_u,fws_u,fsg_u, & + nd_u(iurb),strd,ws,nzurban(iurb),z_u) do iz= kts,kte ua1D(iz)=u_phy(ix,iz,iy) @@ -355,7 +443,7 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do iw=1,nwr_u ! tw1D(2*id-1,iz_u,iw)=tw1_u(ix,iy,ind_zwd(iz_u,iw,id)) ! tw1D(2*id,iz_u,iw)=tw2_u(ix,iy,ind_zwd(iz_u,iw,id)) - if(ind_zwd(iz_u,iw,id).gt.num_urban_layers)write(*,*)'ind_zwd too big w',ind_zwd(iz_u,iw,id) + if(ind_zwd(iz_u,iw,id).gt.urban_map_zwd)write(*,*)'ind_zwd too big w',ind_zwd(iz_u,iw,id) tw1D(2*id-1,iz_u,iw)=tw1_urb4d(ix,ind_zwd(iz_u,iw,id),iy) tw1D(2*id,iz_u,iw)=tw2_urb4d(ix,ind_zwd(iz_u,iw,id),iy) enddo @@ -365,13 +453,13 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do id=1,ndm do ig=1,ng_u ! tg1D(id,ig)=tg_u(ix,iy,ind_gd(ig,id)) - tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy) + tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy) enddo do iz_u=1,nz_um do ir=1,nwr_u ! tr1D(id,iz_u,ir)=tr_u(ix,iy,ind_zwd(iz_u,ir,id)) - if(ind_zwd(iz_u,ir,id).gt.num_urban_layers)write(*,*)'ind_zwd too big r',ind_zwd(iz_u,ir,id) - tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy) + if(ind_zwd(iz_u,ir,id).gt.urban_map_zwd)write(*,*)'ind_zwd too big r',ind_zwd(iz_u,ir,id) + tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zwd(iz_u,ir,id),iy) enddo enddo enddo @@ -406,21 +494,22 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & deltar1D=DECLIN_URB ah1D=OMG_URB2D(ix,iy) ! call angle(xlong(ix,iy),xlat(ix,iy),julday,time_h,zr1D,deltar1D,ah1D) - +! write(*,*) 'entro en BEP1D' call BEP1D(iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D, & zr1D,deltar1D,ah1D,rs1D,rld1D, & - alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & + alag,alaw,alar,csg,csw,csr, & + albg_u(iurb),albw_u(iurb),albr_u(iurb), & + emg_u(iurb),emw_u(iurb),emr_u(iurb), & + fww_u,fwg_u,fgw_u,fsw_u, & + fws_u,fsg_u,z0, & + nd_u(iurb),strd,drst,ws,bs,ss,pb, & + nzurban(iurb),z_u, & tw1D,tg1D,tr1D,sfw1D,sfg1D,sfr1D, & a_u1D,a_v1D,a_t1D,a_e1D, & b_u1D,b_v1D,b_t1D,b_e1D, & - dlg1D,dl_u1D,tsk1D,sf1D,vl1D,rl_up(ix,iy), & + dlg1D,dl_u1D,sf1D,vl1D,rl_up(ix,iy), & rs_abs(ix,iy),emiss(ix,iy),grdflx_urb(ix,iy)) - +! write(*,*) 'salgo de BEP1D' do id=1,ndm do iz=1,nz_um sfw1_urb3d(ix,ind_zd(iz,id),iy)=sfw1D(2*id-1,iz) @@ -457,6 +546,20 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo enddo + + sf(ix,kts:kte,iy)=0. + vl(ix,kts:kte,iy)=0. + a_u(ix,kts:kte,iy)=0. + a_v(ix,kts:kte,iy)=0. + a_t(ix,kts:kte,iy)=0. + a_e(ix,kts:kte,iy)=0. + b_u(ix,kts:kte,iy)=0. + b_v(ix,kts:kte,iy)=0. + b_t(ix,kts:kte,iy)=0. + b_e(ix,kts:kte,iy)=0. + b_q(ix,kts:kte,iy)=0. + dlg(ix,kts:kte,iy)=0. + dl_u(ix,kts:kte,iy)=0. do iz= kts,kte sf(ix,iz,iy)=sf1D(iz) @@ -473,7 +576,6 @@ subroutine BEP(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & dl_u(ix,iz,iy)=dl_u1D(iz) enddo sf(ix,kte+1,iy)=sf1D(kte+1) -! tsk(ix,iy)=tsk1D ! endif ! FRC_URB2D @@ -491,16 +593,15 @@ end subroutine BEP subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & zr,deltar,ah,rs,rld, & - alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & + alag,alaw,alar,csg,csw,csr, & + albg,albw,albr,emg,emw,emr, & + fww,fwg,fgw,fsw,fws,fsg,z0, & + ndu,strd,drst,ws,bs,ss,pb, & + nzu,z_u, & tw,tg,tr,sfw,sfg,sfr, & a_u,a_v,a_t,a_e, & b_u,b_v,b_t,b_e, & - dlg,dl_u,tsk,sf,vl,rl_up,rs_abs,emiss,grdflx_urb) + dlg,dl_u,sf,vl,rl_up,rs_abs,emiss,grdflx_urb) ! ---------------------------------------------------------------------- ! This routine computes the effects of buildings on momentum, heat and @@ -573,20 +674,20 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & integer iurb ! Current urban class ! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] + real alag(ng_u) ! Ground thermal diffusivity [m^2 s^-1] + real alaw(nwr_u) ! Wall thermal diffusivity [m^2 s^-1] + real alar(nwr_u) ! Roof thermal diffusivity [m^2 s^-1] + real csg(ng_u) ! Specific heat of the ground material [J m^3 K^-1] + real csw(nwr_u) ! Specific heat of the wall material [J m^3 K^-1] + real csr(nwr_u) ! Specific heat of the roof material [J m^3 K^-1] ! Radiation parameters - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof + real albg ! Albedo of the ground + real albw ! Albedo of the wall + real albr ! Albedo of the roof + real emg ! Emissivity of ground + real emw ! Emissivity of wall + real emr ! Emissivity of roof ! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long and ! short wave radation. @@ -599,24 +700,20 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real fsg(ndm,nurbm) ! from sky to ground ! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + real z0(ndm,nz_um) ! Roughness lengths "profiles" ! Street parameters - integer nd_u(nurbm) ! Number of street direction for each urban class - real strd_u(ndm,nurbm) ! Street length (set to a greater value then the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction - real ws_u(ndm,nurbm) ! Street width - real bs_u(ndm,nurbm) ! Building width - real h_b(nz_um,nurbm) ! Bulding's heights - real d_b(nz_um,nurbm) ! The probability that a building has an height "h_b" - real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to "z" - real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to "z" + integer ndu ! Number of street direction for each urban class + real strd(ndm) ! Street length (set to a greater value then the horizontal length of the cells) + real drst(ndm) ! Street direction + real ws(ndm) ! Street width + real bs(ndm) ! Building width + real ss(nz_um) ! The probability that a building has an height equal to "z" + real pb(nz_um) ! The probability that a building has an height greater or equal to "z" ! Grid parameters - integer nz_u(nurbm) ! Number of layer in the urban grid -! real dz_u ! Urban grid resolution - real z_u(nz_um) ! Height of the urban grid levels + integer nzu ! Number of layer in the urban grid + real z_u(nz_um) ! Height of the urban grid levels ! ---------------------------------------------------------------------- @@ -655,7 +752,6 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real b_e(kms:kme) ! Explicit component of the TKE sources or sinks real dlg(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper). - real tsk ! Average of the road surface temperatures ! ---------------------------------------------------------------------- ! LOCAL: @@ -672,25 +768,6 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real pt0_u(nz_um) ! Reference potential temperature real pr_u(nz_um) ! Air pressure -! Data defining the building and street charateristics - - integer nd ! Number of street direction for the current urban class - - real alag(ng_u) ! Ground thermal diffusivity for the current urban class [m^2 s^-1] - real alar(nwr_u) ! Roof thermal diffusivity for the current urban class [m^2 s^-1] - real alaw(nwr_u) ! Walls thermal diffusivity for the current urban class [m^2 s^-1] - real csg(ng_u) ! Specific heat of the ground material of the current urban class [J m^3 K^-1] - real csr(nwr_u) ! Specific heat of the roof material for the current urban class [J m^3 K^-1] - real csw(nwr_u) ! Specific heat of the wall material for the current urban class [J m^3 K^-1] - - real z0(ndm,nz_um) ! Roughness lengths "profiles" - real ws(ndm) ! Street widths of the current urban class - real bs(ndm) ! Building widths of the current urban class - real strd(ndm) ! Street lengths for the current urban class - real drst(ndm) ! Street directions for the current urban class - real ss(nz_um) ! Probability to have a building with height h - real pb(nz_um) ! Probability to have a building with an height equal - ! Solar radiation at each level of the "urban grid" real rsg(ndm) ! Short wave radiation from the ground @@ -727,11 +804,8 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real rl_up ! longwave radiation emitted by urban surface to the atmosphere real emiss ! mean emissivity of the urban surface real grdflx_urb ! ground heat flux - real shtot,aaa - real dt_int ! internal time step - integer nt_int ! number of internal time step - integer iz,id, it_int - integer iwrong,iw,ix,iy + integer iz,id + integer iw,ix,iy ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS @@ -742,53 +816,49 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & do iz=kts,kte dz(iz)=z(iz+1)-z(iz) end do - call param(iurb,nz_u(iurb),nd_u(iurb), & - csg_u,csg,alag_u,alag,csr_u,csr, & - alar_u,alar,csw_u,csw,alaw_u,alaw, & - ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, & - strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb) ! Interpolation on the "urban grid" - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,ua,ua_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,va,va_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt,pt_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt0,pt0_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pr,pr_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,da,da_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,ua,ua_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,va,va_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,pt,pt_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,pt0,pt0_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,pr,pr_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,da,da_u) ! Compute the modification of the radiation due to the buildings - call modif_rad(iurb,nd_u(iurb),nz_u(iurb),z_u,ws, & - drst,strd,ss,pb, & - tw,tg,albg_u(iurb),albw_u(iurb), & - emw_u(iurb),emg_u(iurb), & - fww,fwg,fgw,fsw,fsg, & - zr,deltar,ah, & + call modif_rad(iurb,ndu,nzu,z_u,ws, & + drst,strd,ss,pb, & + tw,tg,albg,albw,emw,emg, & + fww,fwg,fgw,fsw,fsg, & + zr,deltar,ah, & rs,rld,rsw,rsg,rlw,rlg) ! calculation of the urban albedo and the upward long wave radiation - call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, & - tg,emg_u(iurb),albg_u(iurb),rlg,rsg,sfg, & - tw,emw_u(iurb),albw_u(iurb),rlw,rsw,sfw, & - tr,emr_u(iurb),albr_u(iurb),rld,rs,sfr, & + + call upward_rad(ndu,nzu,ws,bs, & + sigma,pb,ss, & + tg,emg,albg,rlg,rsg,sfg, & + tw,emw,albw,rlw,rsw,sfw, & + tr,emr,albr,rld,rs,sfr, & rs_abs,rl_up,emiss,grdflx_urb) ! Compute the surface temperatures - call surf_temp(nz_u(iurb),nd_u(iurb),pr_u,dt,ss, & - rs,rld,rsg,rlg,rsw,rlw, & - tg,alag,csg,emg_u(iurb),albg_u(iurb),ptg,sfg,gfg, & - tr,alar,csr,emr_u(iurb),albr_u(iurb),ptr,sfr,gfr, & - tw,alaw,csw,emw_u(iurb),albw_u(iurb),ptw,sfw,gfw) + call surf_temp(nzu,ndu,pr_u,dt,ss, & + rs,rld,rsg,rlg,rsw,rlw, & + tg,alag,csg,emg,albg,ptg,sfg,gfg, & + tr,alar,csr,emr,albr,ptr,sfr,gfr, & + tw,alaw,csw,emw,albw,ptw,sfw,gfw) ! Compute the implicit and explicit components of the sources or sinks on the "urban grid" - call buildings(nd_u(iurb),nz_u(iurb),z0,ua_u,va_u, & - pt_u,pt0_u,ptg,ptr,da_u,ptw,drst, & - uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, & + call buildings(ndu,nzu,z0,ua_u,va_u, & + pt_u,pt0_u,ptg,ptr,da_u,ptw,drst, & + uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, & uhb_u,vhb_u,thb_u,ehb_u,ss,dt) @@ -798,13 +868,13 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ! ! - do id=1,nd_u(iurb) + do id=1,ndu sfg(id)=-da_u(1)*cp_u*thb_u(id,1) - do iz=2,nz_u(iurb) + do iz=2,nzu sfr(id,iz)=-da_u(iz)*cp_u*thb_u(id,iz) enddo - do iz=1,nz_u(iurb) + do iz=1,nzu sfw(2*id-1,iz)=-da_u(iz)*cp_u*(tvb_u(2*id-1,iz)+ & tva_u(2*id-1,iz)*pt_u(iz)) sfw(2*id,iz)=-da_u(iz)*cp_u*(tvb_u(2*id,iz)+ & @@ -814,31 +884,27 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ! calculation of the urban albedo and the upward long wave radiation -! call upward_rad(nd_u(iurb),iurb,nz_u(iurb),ws,bs,sigma,fsw,fsg,pb,ss, & -! tg,emg_u(iurb),albg_u(iurb),rlg,rsg, & -! tw,emw_u(iurb),albw_u(iurb),rlw,rsw, & -! tr,emr_u(iurb),albr_u(iurb),rld,rs, & -! rs_abs,rl_up,emiss) +!! call upward_rad(ndu,nzu,ws,bs, & +!! sigma,pb,ss, & +!! tg,emg,albg,rlg,rsg,sfg, & +!! tw,emw,albw,rlw,rsw,sfw, & +!! tr,emr,albr,rld,rs,sfr, & +!! rs_abs,rl_up,emiss,grdflx_urb) ! Interpolation on the "mesoscale grid" - call urban_meso(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z,dz,z_u,pb,ss,bs,ws,sf, & - vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, & - uhb_u,vhb_u,thb_u,ehb_u, & + call urban_meso(ndu,kms,kme,kts,kte,nzu,z,dz,z_u,pb,ss,bs,ws,sf, & + vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, & + uhb_u,vhb_u,thb_u,ehb_u, & a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e) ! computation of the mean road temperature tsk (this value could be used ! to replace the surface temperature in the radiation routines, if needed). -! tsk=0. -! do id=1,nd_u(iurb) -! tsk=tsk+tg(id,ng_u)/nd_u(iurb) -! enddo - ! Calculation of the length scale taking into account the buildings effects - call interp_length(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z_u,z,ss,ws,bs,dlg,dl_u) + call interp_length(ndu,kms,kme,kts,kte,nzu,z_u,z,ss,ws,bs,dlg,dl_u) return end subroutine BEP1D @@ -846,11 +912,12 @@ end subroutine BEP1D ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine param(iurb,nz,nd, & + subroutine param(iurb,nzu,nzurb,nzurban,ndu, & csg_u,csg,alag_u,alag,csr_u,csr, & alar_u,alar,csw_u,csw,alaw_u,alaw, & ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, & - strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb) + strd_u,strd,drst_u,drst,ss_u,ss_urb,ss,pb_u, & + pb_urb,pb,lp_urb,lb_urb,hgt_urb,frc_urb) ! ---------------------------------------------------------------------- ! This routine prepare some usefull parameters @@ -863,8 +930,9 @@ subroutine param(iurb,nz,nd, & ! INPUT: ! ---------------------------------------------------------------------- integer iurb ! Current urban class - integer nz ! Number of vertical urban levels in the current class - integer nd ! Number of street direction for the current urban class + integer nzu ! Number of vertical urban levels in the current class + integer nzurb ! Number of vertical urban levels in the current class + integer ndu ! Number of street direction for the current urban class real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] @@ -879,7 +947,13 @@ subroutine param(iurb,nz,nd, & real z0r_u(nurbm) ! The roof's roughness length real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to "z" real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to "z" - + real ss_urb(nz_um) ! The probability that a building has an height equal to "z" + real pb_urb(nz_um) ! The probability that a building has an height greater or equal to "z" + real lp_urb ! Building plan area density + real lb_urb ! Building surface area to plan area ratio + real hgt_urb ! Average building height weighted by building plan area [m] + real frc_urb ! Urban fraction + ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- @@ -896,17 +970,18 @@ subroutine param(iurb,nz,nd, & real z0(ndm,nz_um) ! Roughness lengths "profiles" real ss(nz_um) ! Probability to have a building with height h real pb(nz_um) ! Probability to have a building with an height equal + integer nzurban ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- - integer id,ig,ir,iw,iz + integer id,ig,ir,iw,iz,ihu ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- ! -!Initialize the variables +!Initialize ! ss=0. pb=0. @@ -921,11 +996,39 @@ subroutine param(iurb,nz,nd, & bs=0. strd=0. drst=0. + nzurban=0 - do iz=1,nz+1 - ss(iz)=ss_u(iz,iurb) - pb(iz)=pb_u(iz,iurb) - end do + ihu=0 + + do iz=1,nz_um + if (ss_urb(iz)/=0.) then + ihu=1 + exit + else + continue + endif + enddo + + if (ihu==1) then + do iz=1,nzurb+1 + ss(iz)=ss_urb(iz) + pb(iz)=pb_urb(iz) + enddo + nzurban=nzurb + else + do iz=1,nzu+1 + ss(iz)=ss_u(iz,iurb) + pb(iz)=pb_u(iz,iurb) + end do + nzurban=nzu + endif + + do id=1,ndu + z0(id,1)=z0g_u(iurb) + do iz=2,nzurban+1 + z0(id,iz)=z0r_u(iurb) + enddo + enddo do ig=1,ng_u csg(ig)=csg_u(iurb) @@ -941,22 +1044,38 @@ subroutine param(iurb,nz,nd, & csw(iw)=csw_u(iurb) alaw(iw)=alaw_u(iurb) enddo - - do id=1,nd - z0(id,1)=z0g_u(iurb) - do iz=2,nz+1 - z0(id,iz)=z0r_u(iurb) - enddo - enddo - do id=1,nd - ws(id)=ws_u(id,iurb) - bs(id)=bs_u(id,iurb) + do id=1,ndu strd(id)=strd_u(id,iurb) drst(id)=drst_u(id,iurb) enddo - - + + do id=1,ndu + if ((hgt_urb<=0.).OR.(lp_urb<=0.).OR.(lb_urb<=0.)) then + ws(id)=ws_u(id,iurb) + bs(id)=bs_u(id,iurb) + else if ((lp_urb/frc_urb<1.).and.(lp_urb=150.)) then +! write(*,*) 'WARNING, WIDTH OF THE BUILDING WRONG',id,bs(id) +! write(*,*) 'WIDTH OF THE STREET',id,ws(id) + bs(id)=bs_u(id,iurb) + ws(id)=ws_u(id,iurb) + endif + if ((ws(id)<=1.).OR.(ws(id)>=150.)) then +! write(*,*) 'WARNING, WIDTH OF THE STREET WRONG',id,ws(id) +! write(*,*) 'WIDTH OF THE BUILDING',id,bs(id) + bs(id)=bs_u(id,iurb) + ws(id)=ws_u(id,iurb) + endif + enddo return end subroutine param @@ -984,13 +1103,14 @@ subroutine interpol(kms,kme,kts,kte,nz_u,z,z_u,c,c_u) ! Data relative to the "urban grid" integer nz_u ! Number of levels !! real z_u(nz_u+1) ! Altitude of the cell interface - real z_u(nz_um) ! Altitude of the cell interface + real z_u(nz_um) ! Altitude of the cell interface ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- !! real c_u(nz_u) ! Interpolated paramters in the "urban grid" - real c_u(nz_um) ! Interpolated paramters in the "urban grid" + real c_u(nz_um) ! Interpolated paramters in the "urban grid" + ! LOCAL: ! ---------------------------------------------------------------------- integer iz_u,iz @@ -1016,9 +1136,9 @@ end subroutine interpol ! ===6=8===============================================================72 subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & - tw,tg,albg,albw,emw,emg, & - fww,fwg,fgw,fsw,fsg, & - zr,deltar,ah, & + tw,tg,albg,albw,emw,emg, & + fww,fwg,fgw,fsw,fsg, & + zr,deltar,ah, & rs,rl,rsw,rsg,rlw,rlg) ! ---------------------------------------------------------------------- @@ -1074,7 +1194,7 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & ! Calculation of the shadow effects - call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & + call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & rs,rsw,rsg) ! Calculation of the reflection effects @@ -1656,7 +1776,7 @@ end subroutine interp_length ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & + subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & rs,rsw,rsg) ! ---------------------------------------------------------------------- @@ -1735,20 +1855,18 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & do iz=1,nz_u rsw(2*id-1,iz)=0. rsw(2*id,iz)=0. - if(pb(iz+1).gt.0.)then + if(pb(iz+1).gt.0.)then do jz=1,nz_u if(abs(sin(aae)).gt.1.e-10)then call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, & ws(id),rd) rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1) - endif if(abs(sin(aaw)).gt.1.e-10)then call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, & ws(id),rd) - rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1) - + rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1) endif enddo endif @@ -1908,7 +2026,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg, & bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4 do j=1,nz_u bbb(i)=bbb(i)+pb(j+1)*emw*sigma*fww(j,i,id,iurb)* & - tw(2*id,j,nwr_u)**4+ & + tw(2*id,j,nwr_u)**4+ & fww(j,i,id,iurb)*rl*(1.-pb(j+1)) enddo @@ -1936,7 +2054,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg, & do j=1,nz_u bbb(i)=bbb(i)+pb(j+1)*emw*sigma*fww(j,i-nz_u,id,iurb)* & - tw(2*id-1,j,nwr_u)**4+ & + tw(2*id-1,j,nwr_u)**4+ & fww(j,i-nz_u,id,iurb)*rl*(1.-pb(j+1)) enddo @@ -1957,7 +2075,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg, & do i=1,nz_u bbb(2*nz_u+1)=bbb(2*nz_u+1)+emw*sigma*fwg(i,id,iurb)*pb(i+1)* & - (tw(2*id-1,i,nwr_u)**4+tw(2*id,i,nwr_u)**4)+ & + (tw(2*id-1,i,nwr_u)**4+tw(2*id,i,nwr_u)**4)+ & 2.*fwg(i,id,iurb)*(1.-pb(i+1))*rl enddo @@ -2552,65 +2670,19 @@ end subroutine flux_flat ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine icBEP (alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & - fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & - twini_u,trini_u) - - - implicit none - - -! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] - real twini_u(nurbm) ! Temperature inside the buildings behind the wall [K] - real trini_u(nurbm) ! Temperature inside the buildings behind the roof [K] - -! Radiation parameters - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof + subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) -! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + implicit none + ! Street parameters integer nd_u(nurbm) ! Number of street direction for each urban class - - real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction [degree] - real ws_u(ndm,nurbm) ! Street width [m] - real bs_u(ndm,nurbm) ! Building width [m] real h_b(nz_um,nurbm) ! Bulding's heights [m] real d_b(nz_um,nurbm) ! The probability that a building has an height h_b ! ----------------------------------------------------------------------- ! Output !------------------------------------------------------------------------ - - -! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave -! and the short wave radation. They are the part of radiation from a surface -! or from the sky to another surface. - real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall - real fwg(nz_um,ndm,nurbm) ! from wall to ground - real fgw(nz_um,ndm,nurbm) ! from ground to wall - real fsw(nz_um,ndm,nurbm) ! from sky to wall - real fws(nz_um,ndm,nurbm) ! from wall to sky - real fsg(ndm,nurbm) ! from sky to ground - real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to z real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to z @@ -2637,17 +2709,11 @@ subroutine icBEP (alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & ! !Initialize variables ! - nz_u=0 z_u=0. + nz_u=0 ss_u=0. pb_u=0. - fww=0. - fwg=0. - fgw=0. - fsw=0. - fws=0. - fsg=0. - + ! Computation of the urban levels height z_u(1)=0. @@ -2686,10 +2752,6 @@ subroutine icBEP (alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & do id=1,nd_u(iurb) - call view_factors(iurb,nz_u(iurb),id,strd_u(id,iurb), & - z_u,ws_u(id,iurb), & - fww,fwg,fgw,fsg,fsw,fws) - do iz_u=1,nz_u(iurb) ss_u(iz_u,iurb)=0. do ilu=1,nz_um @@ -3020,7 +3082,7 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& do iu=1,icate if(ndm.lt.nd_u(iu))then write(*,*)'ndm too small in module_sf_bep, please increase to at least ', nd_u(iu) - write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!' + write(*,*)'remember also that urban_map_zrd should be equal or greater than nz_um*ndm*nwr-u!' stop endif do i=1,nd_u(iu) @@ -3032,7 +3094,7 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& do iu=1,ICATE if(nz_um.lt.numhgt_tbl(iu)+3)then write(*,*)'nz_um too small in module_sf_bep, please increase to at least ',numhgt_tbl(iu)+3 - write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!' + write(*,*)'remember also that urban_map_zrd should be equal or greater than nz_um*ndm*nwr-u!' stop endif do i=1,NUMHGT_TBL(iu) @@ -3130,12 +3192,14 @@ subroutine angle(along,alat,day,realt,zr,deltar,ah) return END SUBROUTINE angle -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!====6=8===============================================================72 +!====6=8===============================================================72 - subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss, & - tg,emg_u,albg_u,rlg,rsg,sfg, & - tw,emw_u,albw_u,rlw,rsw,sfw, & - tr,emr_u,albr_u,rld,rs, sfr, & + subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & + tg,emg_u,albg_u,rlg,rsg,sfg, & + tw,emw_u,albw_u,rlw,rsw,sfw, & + tr,emr_u,albr_u,rld,rs, sfr, & rs_abs,rl_up,emiss,grdflx_urb) ! ! IN this surboutine we compute the upward longwave flux, and the albedo @@ -3150,11 +3214,11 @@ subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss, & real rlw(2*ndm,nz_um) ! Long wave radiation at the walls for a given canyon direction [W/m2] real rsg(ndm) ! Short wave radiation at the canyon for a given canyon direction [W/m2] real rlg(ndm) ! Long wave radiation at the ground for a given canyon direction [W/m2] - real rs ! Short wave radiation at the horizontal surface from the sun [W/m²] - real sfw(2*ndm,nz_um) ! Sensible heat flux from walls [W/m²] - real sfg(ndm) ! Sensible heat flux from ground (road) [W/m²] - real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/m²] - real rld ! Long wave radiation from the sky [W/m²] + real rs ! Short wave radiation at the horizontal surface from the sun [W/m2] + real sfw(2*ndm,nz_um) ! Sensible heat flux from walls [W/m2] + real sfg(ndm) ! Sensible heat flux from ground (road) [W/m2] + real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/m2] + real rld ! Long wave radiation from the sky [W/m2] real albg_u ! albedo of the ground/street real albw_u ! albedo of the walls real albr_u ! albedo of the roof @@ -3162,20 +3226,17 @@ subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss, & real bs(ndm) ! building size real pb(nz_um) ! Probability to have a building with an height equal or higher - integer nz_u + integer nzu real ss(nz_um) ! Probability to have a building of a given height real sigma real emg_u ! emissivity of the street real emw_u ! emissivity of the wall real emr_u ! emissivity of the roof - real fsw(nz_um,ndm,nurbm) ! View factors from sky to wall - real fsg(ndm,nurbm) ! groud to sky view factor real tw(2*ndm,nz_um,nwr_u) ! Temperature in each layer of the wall [K] real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K] real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] - integer iurb ! urban class integer id ! street direction - integer nd_u ! number of street directions + integer ndu ! number of street directions !OUTPUT/INPUT real rs_abs ! absrobed solar radiationfor this street direction real rl_up ! upward longwave radiation for this street direction @@ -3188,15 +3249,31 @@ subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss, & integer ix,iy,iwrong iwrong=1 - do iz=1,nz_u+1 - do id=1,nd_u + do iz=1,nzu+1 + do id=1,ndu do iw=1,nwr_u if(tr(id,iz,iw).lt.100.)then write(*,*)'in upward_rad ',iz,id,iw,tr(id,iz,iw) iwrong=0 endif + if(tw(2*id-1,iz,iw).lt.100.) then + write(*,*)'in upward_rad ',iz,id,iw,tw(2*id-1,iz,iw) + iwrong=0 + endif + if(tw(2*id,iz,iw).lt.100.) then + write(*,*)'in upward_rad ',iz,id,iw,tw(2*id,iz,iw) + iwrong=0 + endif + enddo enddo enddo + do id=1,ndu + do iw=1,ng_u + if(tg(id,iw).lt.100.) then + write(*,*)'in upward_rad ',id,iw,tg(id,iw) + iwrong=0 + endif + enddo enddo if(iwrong.eq.0)stop @@ -3207,29 +3284,29 @@ subroutine upward_rad(nd_u,iurb,nz_u,ws,bs,sigma,fsw,fsg,pb,ss, & emiss=0. rl_emit=0. grdflx_urb=0. - do id=1,nd_u - rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/nd_u - rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/nd_u - rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/nd_u + do id=1,ndu + rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/ndu + rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/ndu + rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/ndu gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg(id,ng_u)**4.)+sfg(id) - grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/nd_u + grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/ndu - do iz=2,nz_u - rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u - rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u - rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u + do iz=2,nzu + rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu gfl=(1.-albr_u)*rs+emr_u*rld-emr_u*sigma*(tr(id,iz,nwr_u)**4.)+sfr(id,iz) - grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u + grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu enddo - do iz=1,nz_u + do iz=1,nzu rl_emit=rl_emit-(emw_u*sigma*( tw(2*id-1,iz,nwr_u)**4.+tw(2*id,iz,nwr_u)**4. )+ & - (1-emw_u)*( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u - rl_inc=rl_inc+(( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u - rs_abs=rs_abs+((1.-albw_u)*( rsw(2*id-1,iz)+rsw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u + (1-emw_u)*( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu + rl_inc=rl_inc+(( rlw(2*id-1,iz)+rlw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu + rs_abs=rs_abs+((1.-albw_u)*( rsw(2*id-1,iz)+rsw(2*id,iz) ) )*dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu gfl=(1.-albw_u)*(rsw(2*id-1,iz)+rsw(2*id,iz)) +emw_u*( rlw(2*id-1,iz)+rlw(2*id,iz) ) & -emw_u*sigma*( tw(2*id-1,iz,nwr_u)**4.+tw(2*id,iz,nwr_u)**4. )+(sfw(2*id-1,iz)+sfw(2*id,iz)) - grdflx_urb=grdflx_urb-gfl*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u + grdflx_urb=grdflx_urb-gfl*dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu enddo enddo @@ -3243,4 +3320,222 @@ END SUBROUTINE upward_rad !====6=8===============================================================72 !====6=8===============================================================72 +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine icBEP_XY(iurb,fww_u,fwg_u,fgw_u,fsw_u, & + fws_u,fsg_u,ndu,strd,ws,nzu,z_u) + + implicit none + +! Street parameters + integer ndu ! Number of street direction for each urban class + integer iurb + + real strd(ndm) ! Street length (fix to greater value to the horizontal length of the cells) + real ws(ndm) ! Street width [m] + +! Grid parameters + integer nzu ! Number of layer in the urban grid + real z_u(nz_um) ! Height of the urban grid levels +! ----------------------------------------------------------------------- +! Output +!------------------------------------------------------------------------ + +! fww_u,fwg_u,fgw_u,fsw_u,fsg_u are the view factors used to compute the long wave +! and the short wave radation. They are the part of radiation from a surface +! or from the sky to another surface. + + real fww_u(nz_um,nz_um,ndm,nurbm) ! from wall to wall + real fwg_u(nz_um,ndm,nurbm) ! from wall to ground + real fgw_u(nz_um,ndm,nurbm) ! from ground to wall + real fsw_u(nz_um,ndm,nurbm) ! from sky to wall + real fws_u(nz_um,ndm,nurbm) ! from sky to wall + real fsg_u(ndm,nurbm) ! from sky to ground + +! ----------------------------------------------------------------------- +! Local +!------------------------------------------------------------------------ + + integer id + +! ----------------------------------------------------------------------- +! This routine compute the view factors +!------------------------------------------------------------------------ +! +!Initialize +! + fww_u=0. + fwg_u=0. + fgw_u=0. + fsw_u=0. + fws_u=0. + fsg_u=0. + + do id=1,ndu + + call view_factors(iurb,nzu,id,strd(id),z_u,ws(id), & + fww_u,fwg_u,fgw_u,fsg_u,fsw_u,fws_u) + + enddo + return + end subroutine icBEP_XY +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine icBEPHI_XY(hb_u,hi_urb1D,ss_u,pb_u,nzu,z_u) + + implicit none +!----------------------------------------------------------------------- +! Inputs +!----------------------------------------------------------------------- +! Street parameters +! + real hi_urb1D(nz_um) ! The probability that a building has an height h_b +! +! Grid parameters +! + real z_u(nz_um) ! Height of the urban grid levels +! ----------------------------------------------------------------------- +! Output +!------------------------------------------------------------------------ + + real ss_u(nz_um) ! The probability that a building has an height equal to z + real pb_u(nz_um) ! The probability that a building has an height greater or equal to z +! +! Grid parameters +! + integer nzu ! Number of layer in the urban grid + +! ----------------------------------------------------------------------- +! Local +!------------------------------------------------------------------------ + real hb_u(nz_um) ! Bulding's heights [m] + integer iz_u,id,ilu + + real dtot + real hbmax + +!------------------------------------------------------------------------ + +!Initialize variables +! + + nzu=0 + ss_u=0. + pb_u=0. + +! Normalisation of the building density + + dtot=0. + hb_u=0. + + do ilu=1,nz_um + dtot=dtot+hi_urb1D(ilu) + enddo + + do ilu=1,nz_um + if (hi_urb1D(ilu)<0.) then +! write(*,*) 'WARNING, HI_URB1D(ilu) < 0 IN BEP' + go to 20 + endif + enddo + + if (dtot.gt.0.) then + continue + else +! write(*,*) 'WARNING, HI_URB1D <= 0 IN BEP' + go to 20 + endif + + do ilu=1,nz_um + hi_urb1D(ilu)=hi_urb1D(ilu)/dtot + enddo + + hb_u(1)=dz_u + do ilu=2,nz_um + hb_u(ilu)=dz_u+hb_u(ilu-1) + enddo + + +! Compute pb and ss + + + hbmax=0. + + do ilu=1,nz_um + if (hi_urb1D(ilu)>0.and.hi_urb1D(ilu)<=1.) then + hbmax=hb_u(ilu) + endif + enddo + + do iz_u=1,nz_um-1 + if(z_u(iz_u+1).gt.hbmax)go to 10 + enddo + +10 continue + + nzu=iz_u+1 + + if ((nzu+1).gt.nz_um) then + write(*,*) 'error, nz_um has to be increased to at least',nzu+1 + stop + endif + + do iz_u=1,nzu + ss_u(iz_u)=0. + do ilu=1,nz_um + if(z_u(iz_u).le.hb_u(ilu) & + .and.z_u(iz_u+1).gt.hb_u(ilu))then + ss_u(iz_u)=ss_u(iz_u)+hi_urb1D(ilu) + endif + enddo + enddo + + pb_u(1)=1. + do iz_u=1,nzu + pb_u(iz_u+1)=max(0.,pb_u(iz_u)-ss_u(iz_u)) + enddo + +20 continue + return + end subroutine icBEPHI_XY +! ===6=8===============================================================72 +! ===6=8===============================================================72 END MODULE module_sf_bep + + FUNCTION bep_nurbm () RESULT (bep_val_nurbm) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_nurbm + bep_val_nurbm = nurbm + END FUNCTION bep_nurbm + + FUNCTION bep_ndm () RESULT (bep_val_ndm) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_ndm + bep_val_ndm = ndm + END FUNCTION bep_ndm + + FUNCTION bep_nz_um () RESULT (bep_val_nz_um) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_nz_um + bep_val_nz_um = nz_um + END FUNCTION bep_nz_um + + FUNCTION bep_ng_u () RESULT (bep_val_ng_u) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_ng_u + bep_val_ng_u = ng_u + END FUNCTION bep_ng_u + + FUNCTION bep_nwr_u () RESULT (bep_val_nwr_u) + USE module_sf_bep + IMPLICIT NONE + INTEGER :: bep_val_nwr_u + bep_val_nwr_u = nwr_u + END FUNCTION bep_nwr_u + diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F index 5235fd3723..03c86d9347 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_bep_bem.F @@ -1,15 +1,19 @@ MODULE module_sf_bep_bem -#ifdef mpas -use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else -#define FATAL_ERROR(M) write(0,*) M ; stop +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif - -!USE module_model_constants USE module_sf_urban USE module_sf_bem + USE module_bep_bem_helper, ONLY: nurbm ! SGClarke 09/11/2008 ! Access urban_param.tbl values through calling urban_param_init in module_physics_init @@ -19,17 +23,21 @@ MODULE module_sf_bep_bem ! Dimension for the array used in the BEP module ! ----------------------------------------------------------------------- - integer nurbm ! Maximum number of urban classes - parameter (nurbm=3) + integer nurbmax ! Maximum number of urban classes + parameter (nurbmax=11) integer ndm ! Maximum number of street directions parameter (ndm=2) integer nz_um ! Maximum number of vertical levels in the urban grid - parameter(nz_um=13) + parameter(nz_um=18) integer ng_u ! Number of grid levels in the ground parameter (ng_u=10) + + integer ngr_u ! Number of grid levels in green roof + parameter (ngr_u=10) + integer nwr_u ! Number of grid levels in the walls or roofs parameter (nwr_u=10) @@ -40,10 +48,14 @@ MODULE module_sf_bep_bem parameter (ngb_u=10) real dz_u ! Urban grid resolution - parameter (dz_u=5.) + parameter (dz_u=5.) integer nbui_max !maximum number of types of buildings in an urban class - parameter (nbui_max=4) !must be less or equal than nz_um + parameter (nbui_max=15) !must be less or equal than nz_um + + + real h_water + parameter(h_water=0.0009722) !mm of irrigation per hour !--------------------------------------------------------------------------------- !Parameters of the windows. The glasses of windows are considered without films - @@ -56,7 +68,6 @@ MODULE module_sf_bep_bem integer q_num !category number for the windows (q_num= 4, standard glasses) parameter(q_num=4) !Possible values 1,2,...,10 - ! The change of ng_u, nwr_u should be done in agreement with the block data ! in the routine "surf_temp" ! ----------------------------------------------------------------------- @@ -71,10 +82,12 @@ MODULE module_sf_bep_bem real rcp_u ! real sigma ! real p0 ! Reference pressure at the sea level - real cdrag ! Drag force constant real latent ! Latent heat of vaporization [J/kg] (used in BEM) + real dgmax ! Maximum ground water holding capacity (mm) + real drmax ! Maximum ground roof holding capacity (mm) + parameter(vk=0.40,g_u=9.81,pi=3.141592653,r=287.,cp_u=1004.) - parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,cdrag=0.4,latent=2.45e+06) + parameter(rcp_u=r/cp_u,sigma=5.67e-08,p0=1.e+5,latent=2.45e+06,dgmax=1.,drmax=1.) ! ----------------------------------------------------------------------- @@ -84,16 +97,27 @@ MODULE module_sf_bep_bem CONTAINS subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & - th_phy,rho,p_phy,swdown,glw, & + th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat, & declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, & + urban_map_zgrd, num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, & - tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & - cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, & + tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & + cm_ac_urb3d, & + sfvent_urb3d,lfvent_urb3d, & sfwin1_urb3d,sfwin2_urb3d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + ep_pv_urb3d,t_pv_urb3d, & + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & + drain_urb4d,draingr_urb3d, & + sfrv_urb3d,lfrv_urb3d, & + dgr_urb3d,dg_urb3d, & + lfr_urb3d,lfg_urb3d,rainbl,swddir,swddif, & + lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & a_u,a_v,a_t,a_e,b_u,b_v, & b_t,b_e,b_q,dlg,dl_u,sf,vl, & rl_up,rs_abs,emiss,grdflx_urb,qv_phy, & @@ -123,7 +147,9 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: V REAL, DIMENSION( ims:ime , jms:jme ) :: GLW REAL, DIMENSION( ims:ime , jms:jme ) :: swdown - REAL, DIMENSION( ims:ime, jms:jme ) :: UST + REAL, DIMENSION( ims:ime , jms:jme ) :: swddir + REAL, DIMENSION( ims:ime , jms:jme ) :: swddif + REAL, DIMENSION( ims:ime, jms:jme ) :: UST INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: UTYPE_URB2D REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: FRC_URB2D REAL, INTENT(IN ) :: GMT @@ -133,36 +159,67 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & REAL, INTENT(IN) :: DECLIN_URB REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D - INTEGER, INTENT(IN ) :: num_urban_layers - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN) :: num_urban_hi + INTEGER , INTENT(IN) :: urban_map_zgrd + REAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ), INTENT(INOUT) :: trv_urb4d + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ), INTENT(INOUT) :: qr_urb4d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: qgr_urb3d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tgr_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: drain_urb4d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: rainbl + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !New variables used for BEM REAL, DIMENSION( ims:ime, kms:kme, jms:jme ):: qv_phy - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_bd, jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + !End variables - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfrv_urb3d + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: lfrv_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !G + + REAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d + REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lp_urb2d + REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: lb_urb2d + REAL, DIMENSION( ims:ime,jms:jme), INTENT(IN) :: hgt_urb2d real z(ims:ime,kms:kme,jms:jme) ! Vertical coordinates REAL, INTENT(IN ):: DT ! Time step -! !------------------------------------------------------------------------ ! Output !------------------------------------------------------------------------ @@ -184,82 +241,131 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real sf(ims:ime,kms:kme,jms:jme) ! surface of the urban grid cells real vl(ims:ime,kms:kme,jms:jme) ! volume of the urban grid cells ! urban fluxes - real rl_up(ims:ime,jms:jme) ! upward long wave radiation - real rs_abs(ims:ime,jms:jme) ! absorbed short wave radiation - real emiss(ims:ime,jms:jme) ! emissivity averaged for urban surfaces - real grdflx_urb(ims:ime,jms:jme) ! ground heat flux for urban areas + real rl_up(its:ite,jts:jte) ! upward long wave radiation + real rs_abs(its:ite,jts:jte) ! absorbed short wave radiation + real emiss(its:ite,jts:jte) ! emissivity averaged for urban surfaces + real grdflx_urb(its:ite,jts:jte) ! ground heat flux for urban areas !------------------------------------------------------------------------ ! Local !------------------------------------------------------------------------ -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + real hi_urb(its:ite,1:nz_um,jts:jte) ! Height histograms of buildings + real hi_urb1D(nz_um) ! Height histograms of buildings + real ss_urb(nz_um,nurbmax) ! Probability that a building has an height equal to z + real pb_urb(nz_um) ! Probability that a building has an height greater or equal to z + real hb_u(nz_um) ! Bulding's heights + integer nz_urb(nurbmax) ! Number of layer in the urban grid + integer nzurban(nurbmax) + ! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] - real twini_u(nurbm) ! Initial temperature inside the building's wall [K] - real trini_u(nurbm) ! Initial temperature inside the building's roof [K] - real tgini_u(nurbm) ! Initial road temperature + real alag_u(nurbmax) ! Ground thermal diffusivity [m^2 s^-1] + real alaw_u(nurbmax) ! Wall thermal diffusivity [m^2 s^-1] + real alar_u(nurbmax) ! Roof thermal diffusivity [m^2 s^-1] + real csg_u(nurbmax) ! Specific heat of the ground material [J m^3 K^-1] + real csw_u(nurbmax) ! Specific heat of the wall material [J m^3 K^-1] + real csr_u(nurbmax) ! Specific heat of the roof material [J m^3 K^-1] + real twini_u(nurbmax) ! Initial temperature inside the building's wall [K] + real trini_u(nurbmax) ! Initial temperature inside the building's roof [K] + real tgini_u(nurbmax) ! Initial road temperature + +! +! Building materials +! + + real csg(ng_u) ! Specific heat of the ground material [J m^3 K^-1] + real csw(nwr_u) ! Specific heat of the wall material for the current urban class [J m^3 K^-1] + real csr(nwr_u) ! Specific heat of the roof material for the current urban class [J m^3 K^-1] + real csgb(ngb_u) ! Specific heat of the ground material below the buildings at each ground levels[J m^3 K^-1] + real csf(nf_u) ! Specific heat of the floors materials in the buildings at each levels[J m^3 K^-1] + real alar(nwr_u+1) ! Roof thermal diffusivity for the current urban class [W/m K] + real alaw(nwr_u+1) ! Walls thermal diffusivity for the current urban class [W/m K] + real alag(ng_u) ! Ground thermal diffusivity for the current urban class [m^2 s^-1] + real alagb(ngb_u+1) ! Ground thermal diffusivity below the building at each wall layer [W/m K] + real alaf(nf_u+1) ! Floor thermal diffusivity at each wall layers [W/m K] + real dzr(nwr_u) ! Layer sizes in the roofs [m] + real dzf(nf_u) ! Layer sizes in the floors[m] + real dzw(nwr_u) ! Layer sizes in the walls [m] + real dzgb(ngb_u) ! Layer sizes in the ground below the buildings [m] + +! +!New street and radiation parameters + + + real bs(ndm) ! Building width for the current urban class + real ws(ndm) ! Street widths of the current urban class + real strd(ndm) ! Street lengths for the current urban class + real drst(ndm) ! street directions for the current urban class + real ss(nz_um) ! Probability to have a building with height h + real pb(nz_um) ! Probability to have a building with an height equal + real HFGR_D(nz_um) +!New roughness and buildings parameters +! + real z0(ndm,nz_um) ! Roughness lengths "profiles" + real bs_urb(ndm,nurbmax) ! Building width + real ws_urb(ndm,nurbmax) ! Street width + ! ! for twini_u, and trini_u the initial value at the deepest level is kept constant during the simulation ! ! Radiation paramters - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real albwin_u(nurbm) ! Albedo of the windows - real emwind_u(nurbm) ! Emissivity of windows - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof - -! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave -! and the short wave radation. - real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall - real fwg(nz_um,ndm,nurbm) ! from wall to ground - real fgw(nz_um,ndm,nurbm) ! from ground to wall - real fsw(nz_um,ndm,nurbm) ! from sky to wall - real fws(nz_um,ndm,nurbm) ! from sky to wall - real fsg(ndm,nurbm) ! from sky to ground + real albg_u(nurbmax) ! Albedo of the ground + real albw_u(nurbmax) ! Albedo of the wall + real albr_u(nurbmax) ! Albedo of the roof + real albwin_u(nurbmax) ! Albedo of the windows + real emwind_u(nurbmax) ! Emissivity of windows + real emg_u(nurbmax) ! Emissivity of ground + real emw_u(nurbmax) ! Emissivity of wall + real emr_u(nurbmax) ! Emissivity of roof + real gr_frac_roof_u(nurbmax) + real pv_frac_roof_u(nurbmax) + integer gr_flag_u + integer gr_type_u + +! fww_u,fwg_u,fgw_u,fsw_u,fsg_u are the view factors used to compute the long wave +! and the short wave radiation. + real fww_u(nz_um,nz_um,ndm,nurbmax) ! from wall to wall + real fwg_u(nz_um,ndm,nurbmax) ! from wall to ground + real fgw_u(nz_um,ndm,nurbmax) ! from ground to wall + real fsw_u(nz_um,ndm,nurbmax) ! from sky to wall + real fws_u(nz_um,ndm,nurbmax) ! from sky to wall + real fsg_u(ndm,nurbmax) ! from sky to ground ! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + real z0g_u(nurbmax) ! The ground's roughness length + real z0r_u(nurbmax) ! The roof's roughness length ! Street parameters - integer nd_u(nurbm) ! Number of street direction for each urban class - real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction - real ws_u(ndm,nurbm) ! Street width - real bs_u(ndm,nurbm) ! Building width - real h_b(nz_um,nurbm) ! Bulding's heights - real d_b(nz_um,nurbm) ! Probability that a building has an height h_b - real ss_u(nz_um,nurbm) ! Probability that a building has an height equal to z - real pb_u(nz_um,nurbm) ! Probability that a building has an height greater or equal to z + integer nd_u(nurbmax) ! Number of street direction for each urban class + real strd_u(ndm,nurbmax) ! Street length (fix to greater value to the horizontal length of the cells) + real drst_u(ndm,nurbmax) ! Street direction + real ws_u(ndm,nurbmax) ! Street width + real bs_u(ndm,nurbmax) ! Building width + real h_b(nz_um,nurbmax) ! Bulding's heights + real d_b(nz_um,nurbmax) ! Probability that a building has an height h_b + real ss_u(nz_um,nurbmax)! Probability that a building has an height equal to z + real pb_u(nz_um,nurbmax)! Probability that a building has an height greater or equal to z ! Grid parameters - integer nz_u(nurbm) ! Number of layer in the urban grid + integer nz_u(nurbmax) ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels - -! MT - real cop_u(nurbm) - real pwin_u(nurbm) - real beta_u(nurbm) - integer sw_cond_u(nurbm) - real time_on_u(nurbm) - real time_off_u(nurbm) - real targtemp_u(nurbm) - real gaptemp_u(nurbm) - real targhum_u(nurbm) - real gaphum_u(nurbm) - real perflo_u(nurbm) - real hsesf_u(nurbm) +!FS + real cop_u(nurbmax) + real bldac_frc_u(nurbmax) + real cooled_frc_u(nurbmax) + real pwin_u(nurbmax) + real beta_u(nurbmax) + integer sw_cond_u(nurbmax) + real time_on_u(nurbmax) + real time_off_u(nurbmax) + real targtemp_u(nurbmax) + real gaptemp_u(nurbmax) + real targhum_u(nurbmax) + real gaphum_u(nurbmax) + real perflo_u(nurbmax) + real hsesf_u(nurbmax) real hsequip(24) - + real irho(24) ! 1D array used for the input and output of the routine "urban" real z1D(kms:kme) ! vertical coordinates @@ -274,10 +380,17 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real ah1D ! hour angle (it should come from the radiation routine) real rs1D ! solar radiation real rld1D ! downward flux of the longwave radiation + real swddir1D + real swddif1D ! short wave diffuse solar radiation _gl + + real tw1D(2*ndm,nz_um,nwr_u,nbui_max) ! temperature in each layer of the wall real tg1D(ndm,ng_u) ! temperature in each layer of the ground real tr1D(ndm,nz_um,nwr_u) ! temperature in each layer of the roof + real trv1D(ndm,nz_um,ngr_u) ! temperature in each layer of the GREEN roof + real qr1D(ndm,nz_um,ngr_u) ! humidity in each layer of the GREEN roof + ! !New variable for BEM ! @@ -292,12 +405,18 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real sfvlev1D(nz_um,nz_um) ! sensible heat flux due to ventilation real sfwin1D(2*ndm,nz_um,nbui_max) ! sensible heat flux from windows real consumlev1D(nz_um,nz_um) ! consumption due to the air conditioning systems + real eppvlev1D(nz_um) ! electricity production of PV panels + real tair1D(nz_um) + real tpvlev1D(ndm,nz_um) real qv1D(kms:kme) ! specific humidity - real meso_urb ! constant to link meso and urban scales [m¯2] + real meso_urb ! constant to link meso and urban scales [m-2] + real meso_urb_ac + real roof_frac ! Surface fraction occupied by roof real d_urb(nz_um) real sf_ac integer ibui,nbui integer nlev(nz_um) + ! !End new variables ! @@ -305,6 +424,17 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real sfw1D(2*ndm,nz_um,nbui_max) ! sensible heat flux from walls real sfg1D(ndm) ! sensible heat flux from ground (road) real sfr1D(ndm,nz_um) ! sensible heat flux from roofs + real sfrpv1D(ndm,nz_um) + + real tpv1D(nbui_max) + real sfr_indoor1D(nbui_max) + real sfrv1D(ndm,nz_um) ! sensible heat flux from roofs + real lfrv1D(ndm,nz_um) ! latent heat flux from roofs + real dg1D(ndm) ! water depth from ground + real dgr1D(ndm,nz_um) ! water depth from roofs + real lfg1D(ndm) ! latent heat flux from ground (road) + real lfr1D(ndm,nz_um) ! latent heat flux from roofs + real drain1D(ndm,nz_um) ! sensible heat flux from roofs real sf1D(kms:kme) ! surface of the urban grid cells real vl1D(kms:kme) ! volume of the urban grid cells real a_u1D(kms:kme) ! Implicit component of the momentum sources or sinks in the X-direction @@ -319,6 +449,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & real b_q1D(kms:kme) ! Explicit component of the Humidity sources or sinks real dlg1D(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u1D(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper) + real gfr1D(ndm,nz_um) real time_bep ! arrays used to collapse indexes integer ind_zwd(nbui_max,nz_um,nwr_u,ndm) @@ -326,67 +457,73 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & integer ind_zd(nbui_max,nz_um,ndm) integer ind_zdf(nz_um,ndm) integer ind_zrd(nz_um,nwr_u,ndm) + integer ind_grd(nz_um,ngr_u,ndm) ! integer ind_bd(nbui_max,nz_um) integer ind_wd(nbui_max,nz_um,ndm) integer ind_gbd(nbui_max,ngb_u,ndm) integer ind_fbd(nbui_max,nf_u,nz_um-1,ndm) -! + integer ix,iy,iz,iurb,id,iz_u,iw,ig,ir,ix1,iy1,k integer it, nint integer iii - real tempo logical first character(len=80) :: text data first/.true./ - save first,time_bep - - save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,emg_u,emw_u,emr_u,fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u,albwin_u,emwind_u , & - cop_u, pwin_u, beta_u, sw_cond_u, time_on_u, time_off_u, targtemp_u, & - gaptemp_u, targhum_u, gaphum_u, perflo_u, hsesf_u, hsequip + save first,time_bep + + save alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & + albg_u,albw_u,albr_u,emg_u,emw_u,emr_u, & + z0g_u,z0r_u, nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & + nz_u,z_u,albwin_u,emwind_u,cop_u,pwin_u,beta_u,sw_cond_u, & + bldac_frc_u,cooled_frc_u, & + time_on_u,time_off_u,targtemp_u,gaptemp_u,targhum_u,gaphum_u, & + perflo_u,gr_frac_roof_u, & + pv_frac_roof_u,hsesf_u,hsequip,irho,gr_flag_u,gr_type_u !------------------------------------------------------------------------ ! Calculation of the momentum, heat and turbulent kinetic fluxes -! produced by builgings +! produced by buildings ! -! Reference: +! References: ! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE ! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104: ! 261-304 ! ! F. Salamanca and A. Martilli, 2009: 'A new Building Energy Model coupled -! with an Urban Canopy Parameterization for urban climate simulations_part II. +! with an Urban Canopy Parameterization for urban climate simulations - part II. ! Validation with one dimension off-line simulations'. Theor Appl Climatol ! DOI 10.1007/s00704-009-0143-8 !------------------------------------------------------------------------ +! !prepare the arrays to collapse indexes - if(num_urban_layers.lt.nbui_max*nz_um*ndm*max(nwr_u,ng_u))then - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um*ndm*max(nwr_u,ng_u) + + +! + if(urban_map_zwd.lt.nbui_max*nz_um*ndm*max(nwr_u,ng_u))then + write(*,*)'urban_map_zwd too small, please increase to at least ', nbui_max*nz_um*ndm*max(nwr_u,ng_u) stop endif ! !New conditions for BEM ! - if(num_urban_layers.lt.nbui_max*nz_um)then !limit for indoor temperature and indoor humidity - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um + if(urban_map_bd.lt.nbui_max*nz_um)then !limit for indoor temperature and indoor humidity + write(*,*)'urban_map_bd too small, please increase to at least ', nbui_max*nz_um stop endif - if(num_urban_layers.lt.nbui_max*nz_um*ndm)then !limit for window temperature - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*nz_um*ndm + if(urban_map_wd.lt.nbui_max*nz_um*ndm)then !limit for window temperature + write(*,*)'urban_map_wd too small, please increase to at least ', nbui_max*nz_um*ndm stop endif - if(num_urban_layers.lt.nbui_max*ndm*ngb_u)then !limit for ground temperature below a building - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*ndm*ngb_u + if(urban_map_gbd.lt.nbui_max*ndm*ngb_u)then !limit for ground temperature below a building + write(*,*)'urban_map_gbd too small, please increase to at least ', nbui_max*ndm*ngb_u stop endif - if(num_urban_layers.lt.(nz_um-1)*nbui_max*ndm*nf_u)then !limit for floor temperature - write(*,*)'num_urban_layers too small, please increase to at least ', nbui_max*ndm*nf_u*(nz_um-1),num_urban_layers + if(urban_map_fbd.lt.(nz_um-1)*nbui_max*ndm*nf_u)then !limit for floor temperature + write(*,*)'urban_map_fbd too small, please increase to at least ', nbui_max*ndm*nf_u*(nz_um-1) stop endif @@ -395,7 +532,6 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & stop endif -! !End of new conditions ! ! @@ -406,6 +542,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_zd=0 ind_zdf=0 ind_zrd=0 + ind_grd=0 ind_bd=0 ind_wd=0 ind_gbd=0 @@ -425,7 +562,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo enddo - + iii=0 do ig=1,ng_u do id=1,ndm @@ -433,7 +570,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_gd(ig,id)=iii enddo enddo - + iii=0 do ibui=1,nbui_max do iz_u=1,nz_um @@ -443,7 +580,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo enddo - + iii=0 do iz_u=1,nz_um do iw=1,nwr_u @@ -453,10 +590,20 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo enddo enddo - + + iii=0 + do iz_u=1,nz_um + do iw=1,ngr_u + do id=1,ndm + iii=iii+1 + ind_grd(iz_u,iw,id)=iii + enddo + enddo + enddo + ! !New indexes for BEM -! + iii=0 do iz_u=1,nz_um do id=1,ndm @@ -464,7 +611,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_zdf(iz_u,id)=iii enddo ! id enddo ! iz_u - + iii=0 do ibui=1,nbui_max !Type of building do iz_u=1,nz_um !vertical levels @@ -472,8 +619,9 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ind_bd(ibui,iz_u)=iii enddo !iz_u enddo !ibui - - + + + iii=0 do ibui=1,nbui_max !type of building do iz_u=1,nz_um !vertical levels @@ -483,7 +631,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !id enddo !iz_u enddo !ibui - + iii=0 do ibui=1,nbui_max!type of building do iw=1,ngb_u !layers in the wall (ground below a building) @@ -493,7 +641,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !id enddo !iw enddo !ibui - + iii=0 do ibui=1,nbui_max !type of building do iw=1,nf_u !layers in the wall (floor) @@ -505,10 +653,22 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !iz_u enddo !iw enddo !ibui - -! -!End of new indexes -! + + + !End of new indexes + + if (num_urban_hi.ge.nz_um)then + write(*,*)'nz_um too small, please increase to at least ', num_urban_hi+1 + stop + endif + + do ix=its,ite + do iy=jts,jte + do iz_u=1,nz_um + hi_urb(ix,iz_u,iy)=0. + enddo + enddo + enddo do ix=its,ite do iy=jts,jte @@ -516,55 +676,96 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do iz=kts+1,kte+1 z(ix,iz,iy)=z(ix,iz-1,iy)+dz8w(ix,iz-1,iy) enddo + iii=0 + do iz_u=1,num_urban_hi + hi_urb(ix,iz_u,iy)= hi_urb2d(ix,iz_u,iy) + if (hi_urb(ix,iz_u,iy)/=0.) then + iii=iii+1 + endif + enddo !iz_u + if (iii.gt.nbui_max) then + write(*,*) 'nbui_max too small, please increase to at least ',iii + stop + endif enddo enddo + if (first) then ! True only on first call + call init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,& - emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,& - cop_u, pwin_u, beta_u, sw_cond_u, time_on_u, time_off_u, & - targtemp_u, gaptemp_u, targhum_u, gaphum_u, perflo_u, hsesf_u, hsequip) - + emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b, & + cop_u,pwin_u,beta_u,sw_cond_u,time_on_u,time_off_u,targtemp_u, & + bldac_frc_u,cooled_frc_u, & + gaptemp_u,targhum_u,gaphum_u,perflo_u, & + gr_frac_roof_u,pv_frac_roof_u, & + hsesf_u,hsequip,irho,gr_flag_u,gr_type_u) + !Initialisation of the urban parameters and calculation of the view factor - call icBEP(fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u) - - first=.false. + call icBEP(nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) + + first=.false. endif ! first - - do ix=its,ite + +do ix=its,ite do iy=jts,jte if (FRC_URB2D(ix,iy).gt.0.) then ! Calling BEP only for existing urban classes. iurb=UTYPE_URB2D(ix,iy) + + hi_urb1D=0. + do iz_u=1,nz_um + hi_urb1D(iz_u)=hi_urb(ix,iz_u,iy) + + enddo + + call icBEPHI_XY(iurb,hb_u,hi_urb1D,ss_urb,pb_urb, & + nz_urb(iurb),z_u) + + call param(iurb,nz_u(iurb),nz_urb(iurb),nzurban(iurb), & + nd_u(iurb),csg_u,csg,alag_u,alag,csr_u,csr, & + alar_u,alar,csw_u,csw,alaw_u,alaw, & + ws_u,ws_urb,ws,bs_u,bs_urb,bs,z0g_u,z0r_u,z0, & + strd_u,strd,drst_u,drst,ss_u,ss_urb,ss,pb_u, & + pb_urb,pb,dzw,dzr,dzf,csf,alaf,dzgb,csgb,alagb, & + lp_urb2d(ix,iy),lb_urb2d(ix,iy), & + hgt_urb2d(ix,iy),FRC_URB2D(ix,iy)) + +! +!We compute the view factors in the icBEP_XY routine +! + + call icBEP_XY(iurb,fww_u,fwg_u,fgw_u,fsw_u,fws_u,fsg_u, & + nd_u(iurb),strd,ws,nzurban(iurb),z_u) + ibui=0 nlev=0 nbui=0 d_urb=0. do iz=1,nz_um - if(ss_u(iz,iurb).gt.0) then + if(ss_urb(iz,iurb).gt.0) then ibui=ibui+1 nlev(ibui)=iz-1 - d_urb(ibui)=ss_u(iz,iurb) + d_urb(ibui)=ss_urb(iz,iurb) nbui=ibui endif end do !iz + if (nbui.gt.nbui_max) then write (*,*) 'nbui_max must be increased to',nbui stop endif - do iz= kts,kte + + +do iz= kts,kte ua1D(iz)=u_phy(ix,iz,iy) va1D(iz)=v_phy(ix,iz,iy) pt1D(iz)=th_phy(ix,iz,iy) da1D(iz)=rho(ix,iz,iy) pr1D(iz)=p_phy(ix,iz,iy) -! pt01D(iz)=th_phy(ix,iz,iy) pt01D(iz)=300. z1D(iz)=z(ix,iz,iy) qv1D(iz)=qv_phy(ix,iz,iy) @@ -580,6 +781,8 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo z1D(kte+1)=z(ix,kte+1,iy) + + do id=1,ndm do iz_u=1,nz_um do iw=1,nwr_u @@ -592,18 +795,30 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo do id=1,ndm - do ig=1,ng_u + do ig=1,ng_u tg1D(id,ig)=tgb_urb4d(ix,ind_gd(ig,id),iy) - enddo - do iz_u=1,nz_um - do ir=1,nwr_u - tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy) - enddo - enddo - enddo -! + enddo + + do iz_u=1,nz_um + do ir=1,nwr_u + tr1D(id,iz_u,ir)=trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy) + enddo + do ir=1,ngr_u + if(gr_flag_u.eq.1)then + trv1D(id,iz_u,ir)=trv_urb4d(ix,ind_grd(iz_u,ir,id),iy) + qr1D(id,iz_u,ir)=qr_urb4d(ix,ind_grd(iz_u,ir,id),iy) + else + trv1D(id,iz_u,ir)=0. + qr1D(id,iz_u,ir)=0. + endif + enddo + enddo + enddo + + + !Initialize variables for BEM -! + tlev1D=0. !Indoor temperature qlev1D=0. !Indoor humidity @@ -614,6 +829,8 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & sflev1D=0. !Sensible heat flux from the a.c. lflev1D=0. !latent heat flux from the a.c. consumlev1D=0.!consumption of the a.c. + eppvlev1D=0. !electricity production of PV panels + tpvlev1D=0. sfvlev1D=0. !Sensible heat flux from natural ventilation lfvlev1D=0. !Latent heat flux from natural ventilation sfwin1D=0. !Sensible heat flux from windows @@ -626,6 +843,8 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & enddo !ibui enddo !iz_u + + do id=1,ndm !direction do iz_u=1,nz_um !vertical levels do ibui=1,nbui_max !type of building @@ -650,6 +869,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & do iz_u=1,nz_um-1 !verticals levels do ibui=1,nbui_max !type of building tflev1D(id,iw,iz_u,ibui)=tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy) + enddo !ibui enddo ! iz_u enddo !iw @@ -657,176 +877,258 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & ! !End initialization for BEM -! +! + + do id=1,ndm + do iz=1,nz_um + do ibui=1,nbui_max !type of building + !! sfw1D(2*id-1,iz)=sfw1(ix,iy,ind_zd(iz,id)) + !! sfw1D(2*id,iz)=sfw2(ix,iy,ind_zd(iz,id)) + sfw1D(2*id-1,iz,ibui)=sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy) + sfw1D(2*id,iz,ibui)=sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy) + enddo + enddo + enddo + + do id=1,ndm + sfg1D(id)=sfg_urb3d(ix,id,iy) + lfg1D(id)=lfg_urb3d(ix,id,iy) + dg1D(id)=dg_urb3d(ix,id,iy) + + enddo - do id=1,ndm - do iz=1,nz_um - do ibui=1,nbui_max !type of building - sfw1D(2*id-1,iz,ibui)=sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy) - sfw1D(2*id,iz,ibui)=sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy) - enddo - enddo - enddo - - do id=1,ndm - sfg1D(id)=sfg_urb3d(ix,id,iy) - enddo - do id=1,ndm do iz=1,nz_um + tpvlev1D(id,iz)=t_pv_urb3d(ix,ind_zdf(iz,id),iy) sfr1D(id,iz)=sfr_urb3d(ix,ind_zdf(iz,id),iy) + lfr1D(id,iz)=lfr_urb3d(ix,ind_zdf(iz,id),iy) + dgr1D(id,iz)=dgr_urb3d(ix,ind_zdf(iz,id),iy) + if(gr_flag_u.eq.1)then + sfrv1D(id,iz)=sfrv_urb3d(ix,ind_zdf(iz,id),iy) + lfrv1D(id,iz)=lfrv_urb3d(ix,ind_zdf(iz,id),iy) + drain1D(id,iz)=drain_urb4d(ix,ind_zdf(iz,id),iy) + else + sfrv1D(id,iz)=0. + lfrv1D(id,iz)=0. + drain1D(id,iz)=0. + endif enddo enddo - + + + rs1D=swdown(ix,iy) rld1D=glw(ix,iy) - + swddir1D=swddir(ix,iy) !_gl + swddif1D=swddif(ix,iy) !_gl zr1D=acos(COSZ_URB2D(ix,iy)) deltar1D=DECLIN_URB - ah1D=OMG_URB2D(ix,iy) - - call BEP1D(iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D, & - zr1D,deltar1D,ah1D,rs1D,rld1D, & - alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,emr_u, & - emwind_u,fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & - cop_u,pwin_u,beta_u,sw_cond_u,time_on_u, & - time_off_u,targtemp_u,gaptemp_u,targhum_u, & - gaphum_u, perflo_u, hsesf_u, hsequip, & - tw1D,tg1D,tr1D,sfw1D,sfg1D,sfr1D, & + ah1D=OMG_URB2D(ix,iy) + + + call BEP1D(itimestep,ix,iy,iurb,kms,kme,kts,kte,z1D,dt,ua1D,va1D,pt1D,da1D,pr1D,pt01D, & + zr1D,deltar1D,ah1D,rs1D,rld1D,alagb, & + alag,alaw,alar,alaf,csgb,csg,csw,csr,csf, & + dzr,dzf,dzw,dzgb,xlat(ix,iy),swddir1D,swddif1D, & + albg_u(iurb),albw_u(iurb),albr_u(iurb), & + albwin_u(iurb),emg_u(iurb),emw_u(iurb), & + emr_u(iurb),emwind_u(iurb),fww_u,fwg_u, & + fgw_u,fsw_u,fws_u,fsg_u,z0, & + nd_u(iurb),strd,drst,ws,bs_urb,bs,ss,pb, & + nzurban(iurb),z_u,cop_u,pwin_u,beta_u, & + sw_cond_u,time_on_u,time_off_u,targtemp_u, & + gaptemp_u,targhum_u,gaphum_u,perflo_u, & + gr_frac_roof_u(iurb),pv_frac_roof_u(iurb), & + hsesf_u,hsequip,irho,gr_flag_u,gr_type_u, & + tw1D,tg1D,tr1D,trv1D,sfw1D,sfg1D,sfr1D, & + sfrv1D,lfrv1D, & + dgr1D,dg1D,lfr1D,lfg1D, & + drain1D,rainbl(ix,iy),qr1D, & a_u1D,a_v1D,a_t1D,a_e1D, & b_u1D,b_v1D,b_t1D,b_ac1D,b_e1D,b_q1D, & dlg1D,dl_u1D,sf1D,vl1D,rl_up(ix,iy), & rs_abs(ix,iy),emiss(ix,iy),grdflx_urb(ix,iy), & qv1D,tlev1D,qlev1D,sflev1D,lflev1D,consumlev1D, & - sfvlev1D,lfvlev1D,twlev1D,tglev1D,tflev1D,sfwin1D,& - ix,iy) - - do id=1,ndm ! direction + eppvlev1D,tpvlev1D,sfvlev1D,lfvlev1D,twlev1D,tglev1D,tflev1D,sfwin1D,tair1D,sfr_indoor1D,sfrpv1D,gfr1D) + + do ibui=1,nbui_max !type of building do iz=1,nz_um !vertical levels - do ibui=1,nbui_max !type of building + do id=1,ndm ! direction sfw1_urb3d(ix,ind_zd(ibui,iz,id),iy)=sfw1D(2*id-1,iz,ibui) sfw2_urb3d(ix,ind_zd(ibui,iz,id),iy)=sfw1D(2*id,iz,ibui) enddo enddo enddo + do id=1,ndm - sfg_urb3d(ix,id,iy)=sfg1D(id) + sfg_urb3d(ix,id,iy)=sfg1D(id) + lfg_urb3d(ix,id,iy)=lfg1D(id) + dg_urb3d(ix,id,iy)=dg1D(id) enddo do id=1,ndm do iz=1,nz_um + t_pv_urb3d(ix,ind_zdf(iz,id),iy)=tpvlev1D(id,iz) sfr_urb3d(ix,ind_zdf(iz,id),iy)=sfr1D(id,iz) + dgr_urb3d(ix,ind_zdf(iz,id),iy)=dgr1D(id,iz) + lfr_urb3d(ix,ind_zdf(iz,id),iy)=lfr1D(id,iz) + if(gr_flag_u.eq.1)then + sfrv_urb3d(ix,ind_zdf(iz,id),iy)=sfrv1D(id,iz) + lfrv_urb3d(ix,ind_zdf(iz,id),iy)=lfrv1D(id,iz) + drain_urb4d(ix,ind_zdf(iz,id),iy)=drain1D(id,iz) + endif enddo enddo - do id=1,ndm + do ibui=1,nbui_max do iz_u=1,nz_um do iw=1,nwr_u - do ibui=1,nbui_max + do id=1,ndm tw1_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy)=tw1D(2*id-1,iz_u,iw,ibui) tw2_urb4d(ix,ind_zwd(ibui,iz_u,iw,id),iy)=tw1D(2*id,iz_u,iw,ibui) enddo enddo enddo enddo - - do id=1,ndm + + + do id=1,ndm do ig=1,ng_u + tgb_urb4d(ix,ind_gd(ig,id),iy)=tg1D(id,ig) enddo do iz_u=1,nz_um do ir=1,nwr_u trb_urb4d(ix,ind_zrd(iz_u,ir,id),iy)=tr1D(id,iz_u,ir) enddo + if(gr_flag_u.eq.1)then + do ir=1,ngr_u + trv_urb4d(ix,ind_grd(iz_u,ir,id),iy)=trv1D(id,iz_u,ir) + qr_urb4d(ix,ind_grd(iz_u,ir,id),iy)=qr1D(id,iz_u,ir) + enddo + endif enddo - enddo + enddo +! + ! !Outputs of BEM ! + do ibui=1,nbui_max !type of building do iz_u=1,nz_um !vertical levels tlev_urb3d(ix,ind_bd(ibui,iz_u),iy)=tlev1D(iz_u,ibui) qlev_urb3d(ix,ind_bd(ibui,iz_u),iy)=qlev1D(iz_u,ibui) enddo !iz_u enddo !ibui - do id=1,ndm !direction - do iz_u=1,nz_um !vertical levels + do ibui=1,nbui_max !type of building + do iz_u=1,nz_um !vertical levels + do id=1,ndm !direction tw1lev_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=twlev1D(2*id-1,iz_u,ibui) tw2lev_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=twlev1D(2*id,iz_u,ibui) sfwin1_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=sfwin1D(2*id-1,iz_u,ibui) sfwin2_urb3d(ix,ind_wd(ibui,iz_u,id),iy)=sfwin1D(2*id,iz_u,ibui) - enddo !ibui + enddo !id enddo !iz_u - enddo !id + enddo !ibui - do id=1,ndm !direction + do ibui=1,nbui_max !type of building do iw=1,ngb_u !layers in the walls - do ibui=1,nbui_max !type of building + do id=1,ndm !direction tglev_urb3d(ix,ind_gbd(ibui,iw,id),iy)=tglev1D(id,iw,ibui) - enddo !ibui + enddo !id enddo !iw - enddo !id + enddo !ibui - do id=1,ndm !direction - do iw=1,nf_u !layer in the walls + do ibui=1,nbui_max !type of building + do iw=1,nf_u !layer in the walls do iz_u=1,nz_um-1 !verticals levels - do ibui=1,nbui_max !type of building - tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy)=tflev1D(id,iw,iz_u,ibui) + do id=1,ndm + tflev_urb3d(ix,ind_fbd(ibui,iw,iz_u,id),iy)=tflev1D(id,iw,iz_u,ibui) enddo !ibui - enddo !iz_u + enddo ! iz_u enddo !iw enddo !id + + + sf_ac_urb3d(ix,iy)=0. lf_ac_urb3d(ix,iy)=0. cm_ac_urb3d(ix,iy)=0. + ep_pv_urb3d(ix,iy)=0. sfvent_urb3d(ix,iy)=0. lfvent_urb3d(ix,iy)=0. - - meso_urb=(1./4.)*FRC_URB2D(ix,iy)/((bs_u(1,iurb)+ws_u(1,iurb))*bs_u(2,iurb))+ & - (1./4.)*FRC_URB2D(ix,iy)/((bs_u(2,iurb)+ws_u(2,iurb))*bs_u(1,iurb)) - - + draingr_urb3d(ix,iy)=0. + qgr_urb3d(ix,iy)=0. + tgr_urb3d(ix,iy)=0. + meso_urb=(1./4.)*FRC_URB2D(ix,iy)/((bs_urb(1,iurb)+ws_urb(1,iurb))*bs_urb(2,iurb))+ & + (1./4.)*FRC_URB2D(ix,iy)/((bs_urb(2,iurb)+ws_urb(2,iurb))*bs_urb(1,iurb)) + meso_urb_ac=meso_urb*bldac_frc_u(iurb)*cooled_frc_u(iurb) + roof_frac=FRC_URB2D(ix,iy)*bs_urb(1,iurb)/(bs_urb(1,iurb)+ws_urb(1,iurb)) ibui=0 nlev=0 nbui=0 d_urb=0. do iz=1,nz_um - if(ss_u(iz,iurb).gt.0) then + if(ss_urb(iz,iurb).gt.0) then ibui=ibui+1 nlev(ibui)=iz-1 - d_urb(ibui)=ss_u(iz,iurb) + d_urb(ibui)=ss_urb(iz,iurb) nbui=ibui endif end do !iz - do ibui=1,nbui !type of building - do iz_u=1,nlev(ibui) !vertical levels - sf_ac_urb3d(ix,iy)=sf_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*sflev1D(iz_u,ibui) - lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*lflev1D(iz_u,ibui) - cm_ac_urb3d(ix,iy)=cm_ac_urb3d(ix,iy)+meso_urb*d_urb(ibui)*consumlev1D(iz_u,ibui) - sfvent_urb3d(ix,iy)=sfvent_urb3d(ix,iy)+meso_urb*d_urb(ibui)*sfvlev1D(iz_u,ibui) - lfvent_urb3d(ix,iy)=lfvent_urb3d(ix,iy)+meso_urb*d_urb(ibui)*lfvlev1D(iz_u,ibui) + + + + do ibui=1,nbui !type of building + ep_pv_urb3d(ix,iy)=ep_pv_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*eppvlev1D(ibui) + do iz_u=1,nlev(ibui) !vertical levels + sf_ac_urb3d(ix,iy)=sf_ac_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*sflev1D(iz_u,ibui) + lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*lflev1D(iz_u,ibui) + cm_ac_urb3d(ix,iy)=cm_ac_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*consumlev1D(iz_u,ibui) + !if(consumlev1D(iz_u,ibui).gt.0.)then + !print*,'IX',ix,'IY',iy,'IZ_U',iz_u,'IBUI',ibui,'CONSUM',consumlev1D(iz_u,ibui),'D_URB',d_urb(ibui),'MESO_URB',meso_urb_ac + + !endif + sfvent_urb3d(ix,iy)=sfvent_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*sfvlev1D(iz_u,ibui) + lfvent_urb3d(ix,iy)=lfvent_urb3d(ix,iy)+meso_urb_ac*d_urb(ibui)*lfvlev1D(iz_u,ibui) enddo !iz_u enddo !ibui -! -!Add the latent heat exchanged throughout the ventilation in the lf_ac_urb3d output variable. -!it is only a print variable -! -! lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)+lfvent_urb3d(ix,iy) -! + - lf_ac_urb3d(ix,iy)=lf_ac_urb3d(ix,iy)-lfvent_urb3d(ix,iy) -! + if(gr_flag_u.eq.1)then + do id=1,ndm + do iz=2,nz_um-1 + draingr_urb3d(ix,iy)=draingr_urb3d(ix,iy)+d_urb(iz-1)*roof_frac*drain1D(id,iz)*1000 + do ig=1,ngr_u + qgr_urb3d(ix,iy)=qgr_urb3d(ix,iy)+qr1D(id,iz,ig)/ndm/(nz_um-2)/ngr_u + tgr_urb3d(ix,iy)=tgr_urb3d(ix,iy)+trv1D(id,iz,ig)/ndm/(nz_um-2)/ngr_u + + enddo + enddo + enddo + endif !End outputs of bem ! - + sf_ac=0. + sf(ix,kts:kte,iy)=0. + vl(ix,kts:kte,iy)=0. + a_u(ix,kts:kte,iy)=0. + a_v(ix,kts:kte,iy)=0. + a_t(ix,kts:kte,iy)=0. + a_e(ix,kts:kte,iy)=0. + b_u(ix,kts:kte,iy)=0. + b_v(ix,kts:kte,iy)=0. + b_t(ix,kts:kte,iy)=0. + b_e(ix,kts:kte,iy)=0. + b_q(ix,kts:kte,iy)=0. + dlg(ix,kts:kte,iy)=0. + dl_u(ix,kts:kte,iy)=0. + do iz= kts,kte sf(ix,iz,iy)=sf1D(iz) vl(ix,iz,iy)=vl1D(iz) @@ -842,78 +1144,52 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy, & b_q(ix,iz,iy)=b_q1D(iz) dlg(ix,iz,iy)=dlg1D(iz) dl_u(ix,iz,iy)=dl_u1D(iz) - enddo - sf(ix,kte+1,iy)=sf1D(kte+1) + enddo + sf(ix,kte+1,iy)=sf1D(kte+1) endif ! FRC_URB2D - + + enddo ! iy enddo ! ix + time_bep=time_bep+dt +! print*, 'ss_urb', ss_urb +! print*, 'pb_urb', pb_urb +! print*, 'nz_urb', nz_urb +! print*, 'd_urb', d_urb + + return end subroutine BEP_BEM - + + ! ===6=8===============================================================72 - subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & - zr,deltar,ah,rs,rld, & - alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u, & - albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,emr_u, & - emwind_u,fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u, & - cop_u,pwin_u,beta_u,sw_cond_u,time_on_u, & - time_off_u,targtemp_u,gaptemp_u,targhum_u, & - gaphum_u, perflo_u, hsesf_u, hsequip, & - tw,tg,tr,sfw,sfg,sfr, & + subroutine BEP1D(itimestep,ix,iy,iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & + zr,deltar,ah,rs,rld,alagb, & + alag,alaw,alar,alaf,csgb,csg,csw,csr,csf, & + dzr,dzf,dzw,dzgb,xlat,swddir,swddif, & + albg,albw,albr,albwin,emg,emw,emr, & + emwind,fww,fwg,fgw,fsw,fws,fsg,z0, & + ndu,strd,drst,ws,bs_u,bs,ss,pb, & + nzu,z_u,cop_u,pwin_u,beta_u,sw_cond_u, & + time_on_u,time_off_u,targtemp_u, & + gaptemp_u,targhum_u,gaphum_u,perflo_u, & + gr_frac_roof,pv_frac_roof, & + hsesf_u,hsequip,irho,gr_flag,gr_type, & + tw,tg,tr,trv,sfw,sfg,sfr, & + sfrv,lfrv,dgr,dg,lfr,lfg,drain,rainbl,qr, & a_u,a_v,a_t,a_e, & b_u,b_v,b_t,b_ac,b_e,b_q, & dlg,dl_u,sf,vl,rl_up,rs_abs,emiss,grdflx_urb, & qv,tlev,qlev,sflev,lflev,consumlev, & - sfvlev,lfvlev,twlev,tglev,tflev,sfwin,ix,iy) - -! ---------------------------------------------------------------------- -! This routine computes the effects of buildings on momentum, heat and -! TKE (turbulent kinetic energy) sources or sinks and on the mixing length. -! It provides momentum, heat and TKE sources or sinks at different levels of a -! mesoscale grid defined by the altitude of its cell interfaces "z" and -! its number of levels "nz". -! The meteorological input parameters (wind, temperature, solar radiation) -! are specified on the "mesoscale grid". -! The inputs concerning the building and street charateristics are defined -! on a "urban grid". The "urban grid" is defined with its number of levels -! "nz_u" and its space step "dz_u". -! The input parameters are interpolated on the "urban grid". The sources or sinks -! are calculated on the "urban grid". Finally the sources or sinks are -! interpolated on the "mesoscale grid". - + eppvlev,tpvlev,sfvlev,lfvlev,twlev,tglev,tflev,sfwin,tmp_u,sfr_indoor,sfrpv,gfr) + ! print*,'SFR_AFT',sfr(id,iz) + -! Mesoscale grid Urban grid Mesoscale grid -! -! z(4) --- --- -! | | -! | | -! | Interpolation Interpolation | -! | Sources or sinks calculation | -! z(3) --- --- -! | ua ua_u --- uv_a a_u | -! | va va_u | uv_b b_u | -! | pt pt_u --- uh_b a_v | -! z(2) --- | etc... etc...--- -! | z_u(1) --- | -! | | | -! z(1) ------------------------------------------------------------ - -! -! Reference: -! Martilli, A., Clappier, A., Rotach, M.W.:2002, 'AN URBAN SURFACE EXCHANGE -! PARAMETERISATION FOR MESOSCALE MODELS', Boundary-Layer Meteorolgy 104: -! 261-304 - -! ---------------------------------------------------------------------- implicit none @@ -923,7 +1199,8 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ! Data relative to the "mesoscale grid" - integer kms,kme,kts,kte +!! integer nz ! Number of vertical levels + integer kms,kme,kts,kte,ix,iy,itimestep real z(kms:kme) ! Altitude above the ground of the cell interfaces. real ua(kms:kme) ! Wind speed in the x direction real va(kms:kme) ! Wind speed in the y direction @@ -938,28 +1215,24 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real ah ! Hour angle real rs ! Solar radiation real rld ! Downward flux of the longwave radiation + real xlat ! Latitude + real swddir ! short wave direct solar radiation !_gl + real swddif ! short wave diffuse solar radiation !_gl ! Data relative to the "urban grid" integer iurb ! Current urban class -! Building parameters - real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] - real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] - real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] - real csg_u(nurbm) ! Specific heat of the ground material [J m^3 K^-1] - real csw_u(nurbm) ! Specific heat of the wall material [J m^3 K^-1] - real csr_u(nurbm) ! Specific heat of the roof material [J m^3 K^-1] - ! Radiation parameters - real albg_u(nurbm) ! Albedo of the ground - real albw_u(nurbm) ! Albedo of the wall - real albr_u(nurbm) ! Albedo of the roof - real albwin_u(nurbm) ! Albedo of the windows - real emwind_u(nurbm) ! Emissivity of windows - real emg_u(nurbm) ! Emissivity of ground - real emw_u(nurbm) ! Emissivity of wall - real emr_u(nurbm) ! Emissivity of roof + real albg ! Albedo of the ground + real albw ! Albedo of the wall + real albr ! Albedo of the roof + real albwin ! Albedo of the windows + real emwind ! Emissivity of windows + real emg ! Emissivity of ground + real emw ! Emissivity of wall + real emr ! Emissivity of roof + ! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long and ! short wave radation. @@ -970,27 +1243,15 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real fsw(nz_um,ndm,nurbm) ! from sky to wall real fws(nz_um,ndm,nurbm) ! from wall to sky real fsg(ndm,nurbm) ! from sky to ground - -! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length ! Street parameters - integer nd_u(nurbm) ! Number of street direction for each urban class - real strd_u(ndm,nurbm) ! Street length (set to a greater value then the horizontal length of the cells) - real drst_u(ndm,nurbm) ! Street direction - real ws_u(ndm,nurbm) ! Street width + integer ndu ! Number of street direction for each urban class real bs_u(ndm,nurbm) ! Building width - real h_b(nz_um,nurbm) ! Bulding's heights - real d_b(nz_um,nurbm) ! The probability that a building has an height "h_b" - real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to "z" - real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to "z" ! Grid parameters - integer nz_u(nurbm) ! Number of layer in the urban grid + integer nzu ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels - -! MT +!FS real cop_u(nurbm) real pwin_u(nurbm) real beta_u(nurbm) @@ -1004,7 +1265,14 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real perflo_u(nurbm) real hsesf_u(nurbm) real hsequip(24) - + real irho(24) + real gr_frac_roof + real pv_frac_roof + integer gr_flag + integer gr_type + real tpv(nbui_max) + real sfpv(nbui_max) + real sfr_indoor(nbui_max) ! ---------------------------------------------------------------------- ! INPUT-OUTPUT ! ---------------------------------------------------------------------- @@ -1014,15 +1282,27 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real tw(2*ndm,nz_um,nwr_u,nbui_max) ! Temperature in each layer of the wall [K] real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K] real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real trv(ndm,nz_um,ngr_u) ! Temperature in each layer of the green roof [K] real sfw(2*ndm,nz_um,nbui_max) ! Sensible heat flux from walls real sfg(ndm) ! Sensible heat flux from ground (road) real sfr(ndm,nz_um) ! Sensible heat flux from roofs + real sfrv(ndm,nz_um) ! Sensible heat flux from green roofs + real lfrv(ndm,nz_um) ! Latent heat flux from green roofs + real dg(ndm) ! water depth ground (road) + real dgr(ndm,nz_um) ! water depth roofs + real lfr(ndm,nz_um) ! Latent heat flux from roofs + real lfg(ndm) ! Latent heat flux from ground (road) + real drain(ndm,nz_um) ! Green roof drainage + real rainbl ! Rainfall real gfg(ndm) ! Heat flux transferred from the surface of the ground (road) towards the interior real gfr(ndm,nz_um) ! Heat flux transferred from the surface of the roof towards the interior real gfw(2*ndm,nz_um,nbui_max) ! Heat flux transfered from the surface of the walls towards the interior + real qr(ndm,nz_um,ngr_u) ! Green Roof soil moisture + ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- + ! Data relative to the "mesoscale grid" @@ -1043,13 +1323,11 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real b_q(kms:kme) ! Explicit component of the humidity sources or sinks real dlg(kms:kme) ! Height above ground (L_ground in formula (24) of the BLM paper). real dl_u(kms:kme) ! Length scale (lb in formula (22) ofthe BLM paper). - ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- real dz(kms:kme) ! vertical space steps of the "mesoscale grid" - ! Data interpolated from the "mesoscale grid" to the "urban grid" real ua_u(nz_um) ! Wind speed in the x direction @@ -1075,11 +1353,14 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real drst(ndm) ! Street directions for the current urban class real ss(nz_um) ! Probability to have a building with height h real pb(nz_um) ! Probability to have a building with an height equal + real cdrag(nz_um) + real alp ! Solar radiation at each level of the "urban grid" - real rsg(ndm) ! Short wave radiation from the ground + real rsg(ndm) ! Short wave radiation from the ground real rsw(2*ndm,nz_um) ! Short wave radiation from the walls + real rsd(2*ndm,nz_um) ! Direct Short wave radiation received by the walls real rlg(ndm) ! Long wave radiation from the ground real rlw(2*ndm,nz_um) ! Long wave radiation from the walls @@ -1087,9 +1368,10 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real ptg(ndm) ! Ground potential temperatures real ptr(ndm,nz_um) ! Roof potential temperatures + real ptrv(ndm,nz_um) ! Roof potential temperatures real ptw(2*ndm,nz_um,nbui_max) ! Walls potential temperatures - + real tg_av(ndm) ! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on ! vertical surfaces (walls) ans horizontal surfaces (roofs and street) ! The fluxes can be computed as follow: Fluxes of X = A*X + B @@ -1104,7 +1386,9 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real thb_u(ndm,nz_um) ! Temperature Horizontal surfaces, B (explicit) term real tva_u(2*ndm,nz_um) ! Temperature Vertical surfaces, A (implicit) term real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term - real tvb_ac(2*ndm,nz_um) + + + real tvb_ac(2*ndm,nz_um) real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term real qhb_u(ndm,nz_um) ! Humidity Horizontal surfaces, B (explicit) term @@ -1116,8 +1400,8 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real grdflx_urb ! ground heat flux real dt_int ! internal time step integer nt_int ! number of internal time step - integer iz,id, it_int - integer iw,ix,iy + integer iz,id, it_int,it + integer iw !--------------------------------------- !New variables uses in BEM @@ -1131,7 +1415,7 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real dzgb(ngb_u) !Layer sizes in the ground below the buildings real csgb(ngb_u) !Specific heat of the ground material below the buildings - !of the current urban class at each ground levels[J m^3 K^-1] + real csf(nf_u) !Specific heat of the floors materials in the buildings !of the current urban class at each levels[J m^3 K^-1] real alar(nwr_u+1) ! Roof thermal diffusivity for the current urban class [W/m K] @@ -1139,12 +1423,18 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real alaf(nf_u+1) ! Floor thermal diffusivity at each wall layers [W/m K] real alagb(ngb_u+1) ! Ground thermal diffusivity below the building at each wall layer [W/m K] - real sfrb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m²] - real gfrb(ndm,nbui_max) ! Heat flux flowing inside the roofs [W/m²] - real sfwb1D(2*ndm,nz_um) !Sensible heat flux from the walls [W/m²] - real sfwin(2*ndm,nz_um,nbui_max)!Sensible heat flux from windows [W/m²] - real sfwinb1D(2*ndm,nz_um) !Sensible heat flux from windows [W/m²] - real gfwb1D(2*ndm,nz_um) !Heat flux flowing inside the walls [W/m²] + real sfrb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real sfrbpv(ndm,nbui_max) ! Sensible heat flux from PV panels [W/m2] + real sfrpv(ndm,nz_um) ! Sensible heat flux from PV panels [W/m2] + real sfrvb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real lfrvb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + real lfrb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] + + real gfrb(ndm,nbui_max) ! Heat flux flowing inside the roofs [W/m2] + real sfwb1D(2*ndm,nz_um) !Sensible heat flux from the walls [W/m2] + real sfwin(2*ndm,nz_um,nbui_max)!Sensible heat flux from windows [W/m2] + real sfwinb1D(2*ndm,nz_um) !Sensible heat flux from windows [W/m2] + real gfwb1D(2*ndm,nz_um) !Heat flux flowing inside the walls [W/m2] real qlev(nz_um,nbui_max) !specific humidity [kg/kg] real qlevb1D(nz_um) !specific humidity [kg/kg] @@ -1158,14 +1448,18 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real tflev(ndm,nf_u,nz_um-1,nbui_max)!Floor temperature in BEM[K] real tflevb1D(nf_u,nz_um-1) !Floor temperature in BEM[K] real trb(ndm,nwr_u,nbui_max) !Roof temperature in BEM [K] - real trb1D(nwr_u) !Roof temperature in BEM [K] - + real trvb(ndm,ngr_u,nbui_max) !Roof temperature in BEM [K] + real trb1D(nwr_u) + real sflev(nz_um,nz_um) ! sensible heat flux due to the air conditioning systems [W] real lflev(nz_um,nz_um) ! latent heat flux due to the air conditioning systems [W] real consumlev(nz_um,nz_um) ! consumption due to the air conditioning systems [W] real sflev1D(nz_um) ! sensible heat flux due to the air conditioning systems [W] real lflev1D(nz_um) ! latent heat flux due to the air conditioning systems [W] real consumlev1D(nz_um) ! consumption due to the air conditioning systems [W] + real eppvlev(nz_um) ! Electricity production of PV panels [W] + real tpvlev(ndm,nz_um) + real tpvlevb(ndm,nbui_max) ! Sensible heat flux from roofs [W/m2] real sfvlev(nz_um,nz_um) ! sensible heat flux due to ventilation [W] real lfvlev(nz_um,nz_um) ! latent heat flux due to ventilation [W] real sfvlev1D(nz_um) ! sensible heat flux due to ventilation [W] @@ -1176,71 +1470,136 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & real twlev_av(2*ndm,nz_um) ! Averaged temperature of the windows real sfw_av(2*ndm,nz_um) ! Averaged sensible heat from walls real sfwind_av(2*ndm,nz_um) ! Averaged sensible heat from windows - + integer flag_pvp integer nbui !Total number of different type of buildings in an urban class integer nlev(nz_um) !Number of levels in each different type of buildings in an urban class integer ibui,ily real :: nhourday ! Number of hours from midnight, local time + real :: st4,gamma,fp,lmr,smr,prova + real hfgr(ndm,nz_um)!heat flux green roof + real hfgrb(ndm,nbui_max) + real irri_per_ts + real irri_now + real tr_av(ndm,nz_um) + real tr_avb(ndm,nbui_max) + real sfr_avb(ndm,nbui_max) ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- - + ! Fix some usefull parameters for the computation of the sources or sinks ! -!initialize inside param -! -! ss=0. -! pb=0. +!initialize the variables inside the param routine + + nhourday=ah/PI*180./15.+12. + if (nhourday >= 24) nhourday = nhourday - 24 + if (nhourday < 0) nhourday = nhourday + 24 + + if(sum(irho).gt.0)then + irri_per_ts=h_water/sum(irho) + else + irri_per_ts=0. + endif + + if(irho(int(nhourday)+1).ne.0)then + irri_now=irri_per_ts + else + irri_now=0. + endif + do iz=kts,kte dz(iz)=z(iz+1)-z(iz) end do - call param(iurb,nz_u(iurb),nd_u(iurb), & - csg_u,csg,alag_u,alag,csr_u,csr, & - alar_u,alar,csw_u,csw,alaw_u,alaw, & - ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, & - strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb, & - dzw,dzr,dzf,csf,alaf,dzgb,csgb,alagb) - ! Interpolation on the "urban grid" - - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,ua,ua_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,va,va_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt,pt_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pt0,pt0_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,pr,pr_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,da,da_u) - call interpol(kms,kme,kts,kte,nz_u(iurb),z,z_u,qv,qv_u) - + call interpol(kms,kme,kts,kte,nzu,z,z_u,ua,ua_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,va,va_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,pt,pt_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,pt0,pt0_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,pr,pr_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,da,da_u) + call interpol(kms,kme,kts,kte,nzu,z,z_u,qv,qv_u) ! Compute the modification of the radiation due to the buildings + call averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av, & - sfw_av,sfwind_av,sfw,sfwin) - call modif_rad(iurb,nd_u(iurb),nz_u(iurb),z_u,ws, & - drst,strd,ss,pb, & - tw_av,tg,twlev_av,albg_u(iurb),albw_u(iurb), & - emw_u(iurb),emg_u(iurb),pwin_u(iurb),albwin_u(iurb), & - emwind_u(iurb),fww,fwg,fgw,fsw,fsg, & - zr,deltar,ah, & - rs,rld,rsw,rsg,rlw,rlg) + sfw_av,sfwind_av,sfw,sfwin) + + do id=1,ndu + tg_av(id)=tg(id,ng_u) + do iz=1,nz_um + + tr_av(id,iz)=((1-gr_frac_roof)*tr(id,iz,nwr_u)**4.+ & + gr_frac_roof*trv(id,iz,ngr_u)**4.)**(1./4.) + + enddo + enddo + + + + + + call modif_rad(iurb,ndu,nzu,z_u,ws, & + drst,strd,ss,pb, & + tw_av,tg_av,twlev_av,albg,albw, & + emw,emg,pwin_u(iurb),albwin, & + emwind,fww,fwg,fgw,fsw,fsg, & + zr,deltar,ah,xlat,swddir,swddif, & !_gl + rs,rld,rsw,rsd,rsg,rlw,rlg) + + + ! calculation of the urban albedo and the upward long wave radiation - call upward_rad(nd_u(iurb),nz_u(iurb),ws,bs,sigma,pb,ss, & - tg,emg_u(iurb),albg_u(iurb),rlg,rsg,sfg, & - tw_av,emw_u(iurb),albw_u(iurb),rlw,rsw,sfw_av, & - tr,emr_u(iurb),albr_u(iurb),emwind_u(iurb), & - albwin_u(iurb),twlev_av,pwin_u(iurb),sfwind_av,rld,rs,sfr, & - rs_abs,rl_up,emiss,grdflx_urb) -! Compute the surface temperatures - - call surf_temp(nd_u(iurb),pr_u,dt, & - rld,rsg,rlg, & - tg,alag,csg,emg_u(iurb),albg_u(iurb),ptg,sfg,gfg) + call upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & + tg_av,emg,albg,rlg,rsg,sfg,lfg, & + tw_av,emw,albw,rlw,rsw,sfw_av, & + tr_av,emr,albr,emwind, & + albwin,twlev_av,pwin_u(iurb),sfwind_av,rld,rs,sfr,sfrv,lfr,lfrv, & + rs_abs,rl_up,emiss,grdflx_urb,gr_frac_roof,tpvlev,pv_frac_roof) + + do id=1,ndu + if(dg(id).le.dgmax) then + dg(id)=dg(id)+(rainbl+(lfg(id)*dt)/latent) + endif + if (dg(id).lt.0) then + dg(id)=0 + endif + if (dg(id).gt.dgmax) then + dg(id)=dgmax + endif + do iz=2,nz_um + if(dgr(id,iz).le.drmax) then + dgr(id,iz)=dgr(id,iz)+(rainbl+(lfr(id,iz)*dt)/latent) + endif + if (dgr(id,iz).lt.0) then + dgr(id,iz)=0 + endif + if (dgr(id,iz).gt.drmax) then + dgr(id,iz)=drmax + endif + enddo + enddo !id + + + + + call surf_temp(ndu,pr_u,dt, & + rld,rsg,rlg, & + tg,alag,csg,emg,albg,ptg,sfg,lfg,gfg) + if(gr_flag.eq.1)then + if(gr_frac_roof.gt.0.)then + hfgr=0. + call roof_temp_veg(ndu,pr_u,dt, & + rld,rs, & + trv,ptrv,sfrv,lfrv,gfr,qr,rainbl,drain,hfgr,tr,alar(5),dzr(5),csr(5),nzu,irri_now,gr_type,pv_frac_roof,tpvlev) + + endif + endif -! Call the BEM (Building Energy Model) routine do iz=1,nz_um !Compute the outdoor temperature tmp_u(iz)=pt_u(iz)*(pr_u(iz)/p0)**(rcp_u) @@ -1249,63 +1608,77 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & ibui=0 nlev=0 nbui=0 - + hfgrb=0. sfrb=0. !Sensible heat flux from roof + sfrbpv=0. !Sensible heat flux from PV panels + sfrpv=0. !Sensible heat flux from PV panels + lfrvb=0. + lfrb=0. + sfrvb=0. gfrb=0. !Heat flux flowing inside the roof sfwb1D=0. !Sensible heat flux from walls sfwinb1D=0. !Sensible heat flux from windows - gfwb1D=0. !Heat flux flowing inside the walls[W/m²] + gfwb1D=0. !Heat flux flowing inside the walls[W/m2] twb1D=0. !Wall temperature twlevb1D=0. !Window temperature tglevb1D=0. !Ground temperature below a building - tflevb1D=0. !Floor temperature + tflevb1D=0. !Floor temperature + trvb=0. trb=0. !Roof temperature trb1D=0. !Roof temperature - + tr_avb=0. qlevb1D=0. !Indoor humidity tlevb1D=0. !indoor temperature sflev1D=0. !Sensible heat flux from the a.c. lflev1D=0. !Latent heat flux from the a.c. consumlev1D=0.!Consumption from the a.c. + tpvlevb=0. + eppvlev=0. sfvlev1D=0. !Sensible heat flux from the natural ventilation lfvlev1D=0. !Latent heat flux from natural ventilation - ptw=0. !Wall potential temperature ptwin=0. !Window potential temperature ptr=0. !Roof potential temperature - + do iz=1,nz_um if(ss(iz).gt.0) then ibui=ibui+1 nlev(ibui)=iz-1 nbui=ibui do id=1,ndm + tr_avb(id,ibui)=tr_av(id,iz) + tpvlevb(id,ibui)=tpvlev(id,iz) + hfgrb(id,ibui)=hfgr(id,iz) sfrb(id,ibui)=sfr(id,iz) + sfrvb(id,ibui)=sfrv(id,iz) + lfrvb(id,ibui)=lfrv(id,iz) + lfrb(id,ibui)=lfr(id,iz) + sfr_avb(id,ibui)=(1-gr_frac_roof)*sfr(id,iz)+gr_frac_roof*(sfrv(id,iz)) do ily=1,nwr_u trb(id,ily,ibui)=tr(id,iz,ily) enddo + do ily=1,ngr_u + trvb(id,ily,ibui)=trv(id,iz,ily) + enddo + enddo endif - end do !iz + end do !iz + !-------------------------------------------------------------------------------- !Loop over BEM ----------------------------------------------------------------- !-------------------------------------------------------------------------------- !-------------------------------------------------------------------------------- - - nhourday=ah/PI*180./15.+12. - if (nhourday >= 24) nhourday = nhourday - 24 - if (nhourday < 0) nhourday = nhourday + 24 - do ibui=1,nbui - + do ibui=1,nbui do iz=1,nz_um qlevb1D(iz)=qlev(iz,ibui) tlevb1D(iz)=tlev(iz,ibui) enddo - + do id=1,ndm do ily=1,nwr_u @@ -1314,18 +1687,18 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & do ily=1,ngb_u tglevb1D(ily)=tglev(id,ily,ibui) enddo - + do ily=1,nf_u - do iz=1,nz_um-1 - tflevb1D(ily,iz)=tflev(id,ily,iz,ibui) - enddo + do iz=1,nz_um-1 + tflevb1D(ily,iz)=tflev(id,ily,iz,ibui) + enddo enddo - + do iz=1,nz_um sfwinb1D(2*id-1,iz)=sfwin(2*id-1,iz,ibui) sfwinb1D(2*id,iz)=sfwin(2*id,iz,ibui) enddo - + do iz=1,nz_um do ily=1,nwr_u twb1D(2*id-1,ily,iz)=tw(2*id-1,iz,ily,ibui) @@ -1336,29 +1709,42 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & twlevb1D(2*id-1,iz)=twlev(2*id-1,iz,ibui) twlevb1D(2*id,iz)=twlev(2*id,iz,ibui) enddo - enddo - - call BEM(nz_um,nlev(ibui),nhourday,dt,bs_u(1,iurb), & - bs_u(2,iurb),dz_u,nwr_u,nf_u,nwr_u,ngb_u,sfwb1D,gfwb1D, & - sfwinb1D,sfrb(1,ibui),gfrb(1,ibui), & - latent,sigma,albw_u(iurb),albwin_u(iurb),albr_u(iurb), & - emr_u(iurb),emw_u(iurb),emwind_u(iurb),rsw,rlw,r,cp_u, & - da_u,tmp_u,qv_u,pr_u,rs,rld,dzw,csw,alaw,pwin_u(iurb), & - cop_u(iurb),beta_u(iurb),sw_cond_u(iurb),time_on_u(iurb), & - time_off_u(iurb),targtemp_u(iurb),gaptemp_u(iurb), & - targhum_u(iurb),gaphum_u(iurb),perflo_u(iurb),hsesf_u(iurb), & - hsequip, & - dzf,csf,alaf,dzgb,csgb,alagb,dzr,csr, & - alar,tlevb1D,qlevb1D,twb1D,twlevb1D,tflevb1D,tglevb1D, & - trb1D,sflev1D,lflev1D,consumlev1D,sfvlev1D,lfvlev1D) - - + enddo + + !print*,'HFGR_BEFORE_CALLING_BEM',hfgr(nlev(ibui)) + + call BEM(nz_um,nlev(ibui),nhourday,dt,bs_u(1,iurb), & + bs_u(2,iurb),dz_u,nwr_u,nf_u,nwr_u,ngb_u,sfwb1D,gfwb1D, & + sfwinb1D,sfr_avb(1,ibui),lfrb(1,ibui),gfrb(1,ibui), & + sfrbpv(1,ibui), & + latent,sigma,albw,albwin,albr, & + emr,emw,emwind,rsw,rlw,r,cp_u, & + da_u,tmp_u,qv_u,pr_u,rs,swddif,rld,dzw,csw,alaw,pwin_u(iurb), & + cop_u(iurb),beta_u(iurb),sw_cond_u(iurb),time_on_u(iurb), & + time_off_u(iurb),targtemp_u(iurb),gaptemp_u(iurb), & + targhum_u(iurb),gaphum_u(iurb),perflo_u(iurb), & + gr_frac_roof,pv_frac_roof,gr_flag, & + ua_u,va_u, & + hsesf_u(iurb),hsequip, & + dzf,csf,alaf,dzgb,csgb,alagb,dzr,csr, & + alar,tlevb1D,qlevb1D,twb1D,twlevb1D,tflevb1D,tglevb1D, & + trb1D,sflev1D,lflev1D,consumlev1D,eppvlev(ibui), & + tpvlevb(1,ibui), & + sfvlev1D,lfvlev1D,hfgrb(1,ibui),tr_avb(1,ibui), & + tpv(ibui),sfpv(ibui),sfr_indoor(ibui)) + + ! !Temporal modifications -! +! + tpvlevb(2,ibui)=tpvlevb(1,ibui) sfrb(2,ibui)=sfrb(1,ibui) + sfrvb(2,ibui)=sfrvb(1,ibui) + lfrvb(2,ibui)=lfrvb(1,ibui) + lfrb(2,ibui)=lfrb(1,ibui) + sfrbpv(2,ibui)=sfrbpv(1,ibui) gfrb(2,ibui)=gfrb(1,ibui) -! + hfgrb(2,ibui)=hfgrb(1,ibui) !End temporal modifications ! do iz=1,nz_um @@ -1398,78 +1784,105 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0, & enddo enddo - enddo !ibui - + enddo !ibui + !----------------------------------------------------------------------------- !End loop over BEM ----------------------------------------------------------- !----------------------------------------------------------------------------- !----------------------------------------------------------------------------- ibui=0 - do iz=1,nz_um + + do iz=1,nzu!nz_um + if(ss(iz).gt.0) then ibui=ibui+1 do id=1,ndm gfr(id,iz)=gfrb(id,ibui) + tpvlev(id,iz)=tpvlevb(id,ibui) sfr(id,iz)=sfrb(id,ibui) + hfgr(id,iz)=hfgrb(id,ibui) + sfrpv(id,iz)=-sfrbpv(id,ibui) + lfr(id,iz)=lfrb(id,ibui) do ily=1,nwr_u tr(id,iz,ily)=trb(id,ily,ibui) enddo ptr(id,iz)=tr(id,iz,nwr_u)*(pr_u(iz)/p0)**(-rcp_u) enddo endif - enddo !iz + enddo !iz !Compute the potential temperature for the vertical surfaces of the buildings - + do id=1,ndm - do iz=1,nz_um + do iz=1,nzu!nz_um do ibui=1,nbui ptw(2*id-1,iz,ibui)=tw(2*id-1,iz,nwr_u,ibui)*(pr_u(iz)/p0)**(-rcp_u) ptw(2*id,iz,ibui)=tw(2*id,iz,nwr_u,ibui)*(pr_u(iz)/p0)**(-rcp_u) ptwin(2*id-1,iz,ibui)=twlev(2*id-1,iz,ibui)*(pr_u(iz)/p0)**(-rcp_u) ptwin(2*id,iz,ibui)=twlev(2*id,iz,ibui)*(pr_u(iz)/p0)**(-rcp_u) + enddo enddo enddo +!NEW CDRAG! + do iz=1,nz_um + alp=0. + do id=1,ndu + alp=alp+bs(id)/(ws(id)+bs(id))*pb(iz) + enddo + alp=alp/ndu + if(alp.lt.0.29)then + cdrag(iz)=3.32*alp**0.47 + else + cdrag(iz)=1.85 + endif + enddo + + ! Compute the implicit and explicit components of the sources or sinks on the "urban grid" - - call buildings(iurb,nd_u(iurb),nz_u(iurb),z0,ua_u,va_u, & - pt_u,pt0_u,ptg,ptr,da_u,ptw,ptwin,pwin_u(iurb),drst, & + + call buildings(iurb,ndu,nzu,z0,cdrag,ua_u,va_u, & + pt_u,pt0_u,ptg,ptr,ptrv,da_u,qv_u,pr_u,tmp_u,ptw,ptwin,pwin_u(iurb),drst, & uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u,qvb_u,qhb_u, & - uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr, & - sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac) - + uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr,sfrpv,sfrv,lfrv, & + dgr,dg,lfr,lfg, & + sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac,ix,iy,rsg,rs,qr,gr_frac_roof, & + pv_frac_roof,gr_flag,gr_type) + + + + ! Calculation of the sensible heat fluxes for the ground, the wall and roof ! Sensible Heat Flux = density * Cp_U * ( A* potential temperature + B ) ! where A and B are the implicit and explicit components of the heat sources or sinks. - ! Interpolation on the "mesoscale grid" - call urban_meso(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z,dz,z_u,pb,ss,bs,ws,sf, & - vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, & - uhb_u,vhb_u,thb_u,ehb_u,qhb_u,qvb_u, & + call urban_meso(ndu,kms,kme,kts,kte,nzu,z,dz,z_u,pb,ss,bs,ws,sf, & + vl,uva_u,vva_u,uvb_u,vvb_u,tva_u,tvb_u,evb_u, & + uhb_u,vhb_u,thb_u,ehb_u,qhb_u,qvb_u, & a_u,a_v,a_t,a_e,b_u,b_v,b_t,b_e,b_q,tvb_ac,b_ac) ! Calculation of the length scale taking into account the buildings effects - call interp_length(nd_u(iurb),kms,kme,kts,kte,nz_u(iurb),z_u,z,ss,ws,bs,dlg,dl_u) - + call interp_length(ndu,kms,kme,kts,kte,nzu,z_u,z,ss,ws,bs,dlg,dl_u) + return end subroutine BEP1D ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine param(iurb,nz,nd, & + subroutine param(iurb,nzu,nzurb,nzurban,ndu, & csg_u,csg,alag_u,alag,csr_u,csr, & alar_u,alar,csw_u,csw,alaw_u,alaw, & - ws_u,ws,bs_u,bs,z0g_u,z0r_u,z0, & - strd_u,strd,drst_u,drst,ss_u,ss,pb_u,pb, & - dzw,dzr,dzf,csf,alaf,dzgb,csgb,alagb) + ws_u,ws_urb,ws,bs_u,bs_urb,bs,z0g_u,z0r_u,z0, & + strd_u,strd,drst_u,drst,ss_u,ss_urb,ss,pb_u, & + pb_urb,pb,dzw,dzr,dzf,csf,alaf,dzgb,csgb,alagb,& + lp_urb,lb_urb,hgt_urb,frc_urb) ! ---------------------------------------------------------------------- ! This routine prepare some usefull parameters @@ -1482,8 +1895,9 @@ subroutine param(iurb,nz,nd, & ! INPUT: ! ---------------------------------------------------------------------- integer iurb ! Current urban class - integer nz ! Number of vertical urban levels in the current class - integer nd ! Number of street direction for the current urban class + integer nzu ! Number of vertical urban levels in the current class + integer ndu ! Number of street direction for the current urban class + integer nzurb ! Number of vertical urban levels in the current class real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] real alar_u(nurbm) ! Roof thermal diffusivity [m^2 s^-1] real alaw_u(nurbm) ! Wall thermal diffusivity [m^2 s^-1] @@ -1498,7 +1912,10 @@ subroutine param(iurb,nz,nd, & real z0r_u(nurbm) ! The roof's roughness length real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to "z" real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to "z" - + real lp_urb ! Building plan area density + real lb_urb ! Building surface area to plan area ratio + real hgt_urb ! Average building height weighted by building plan area [m] + real frc_urb ! Urban fraction ! ---------------------------------------------------------------------- ! OUTPUT: @@ -1512,6 +1929,7 @@ subroutine param(iurb,nz,nd, & real z0(ndm,nz_um) ! Roughness lengths "profiles" real ss(nz_um) ! Probability to have a building with height h real pb(nz_um) ! Probability to have a building with an height greater or equal to "z" + integer nzurban !----------------------------------------------------------------------------- !INPUT/OUTPUT @@ -1533,19 +1951,28 @@ subroutine param(iurb,nz,nd, & real alaw(nwr_u+1) ! Wall thermal diffusivity at each wall levels [W/ m K] real alaf(nf_u+1) ! Floor thermal diffusivity at each wall levels [W/m K] real alagb(ngb_u+1) ! Ground thermal diffusivity below the building at each wall levels [W/m K] + real bs_urb(ndm,nurbm) ! Building width + real ws_urb(ndm,nurbm) ! Street width + real ss_urb(nz_um,nurbm) ! The probability that a building has an height equal to "z" + real pb_urb(nz_um) ! Probability that a building has an height greater or equal to z ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- - integer id,ig,ir,iw,iz,iflo + integer id,ig,ir,iw,iz,iflo,ihu ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- -!Define the layer sizes in the walls - +! +!Initialize variables +! ss=0. pb=0. csg=0. alag=0. + csgb=0. + alagb=0. + csf=0. + alaf=0. csr=0. alar=0. csw=0. @@ -1553,24 +1980,52 @@ subroutine param(iurb,nz,nd, & z0=0. ws=0. bs=0. + bs_urb=0. + ws_urb=0. strd=0. drst=0. - csgb=0. - alagb=0. - csf=0. - alaf=0. - + nzurban=0 + +!Define the layer sizes in the walls + dzgb=(/0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/) dzr=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/) dzw=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.01,0.005,0.0025/) - dzf=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02/) + dzf=(/0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02,0.02/) + + ihu=0 + + do iz=1,nz_um + if (ss_urb(iz,iurb)/=0.) then + ihu=1 + exit + else + continue + endif + enddo + + if (ihu==1) then + do iz=1,nzurb+1 + ss(iz)=ss_urb(iz,iurb) + pb(iz)=pb_urb(iz) + enddo + nzurban=nzurb + else + do iz=1,nzu+1 + ss(iz)=ss_u(iz,iurb) + pb(iz)=pb_u(iz,iurb) + ss_urb(iz,iurb)=ss_u(iz,iurb) + pb_urb(iz)=pb_u(iz,iurb) + end do + nzurban=nzu + endif do ig=1,ngb_u csgb(ig) = csg_u(iurb) alagb(ig)= csg_u(iurb)*alag_u(iurb) enddo alagb(ngb_u+1)= csg_u(iurb)*alag_u(iurb) - + do iflo=1,nf_u csf(iflo) = csw_u(iurb) alaf(iflo)= csw_u(iurb)*alaw_u(iurb) @@ -1590,32 +2045,56 @@ subroutine param(iurb,nz,nd, & alaw(nwr_u+1)=csw_u(iurb)*alaw_u(iurb) !------------------------------------------------------------------------ - - do iz=1,nz+1 - ss(iz)=ss_u(iz,iurb) - pb(iz)=pb_u(iz,iurb) - end do do ig=1,ng_u csg(ig)=csg_u(iurb) alag(ig)=alag_u(iurb) enddo - do id=1,nd - z0(id,1)=z0g_u(iurb) - do iz=2,nz+1 - z0(id,iz)=z0r_u(iurb) + do id=1,ndu + z0(id,1)=z0g_u(iurb) + do iz=2,nzurban+1 + z0(id,iz)=z0r_u(iurb) enddo enddo - do id=1,nd - ws(id)=ws_u(id,iurb) - bs(id)=bs_u(id,iurb) - strd(id)=strd_u(id,iurb) - drst(id)=drst_u(id,iurb) + do id=1,ndu + strd(id)=strd_u(id,iurb) + drst(id)=drst_u(id,iurb) enddo - + do id=1,ndu + if ((hgt_urb<=0.).OR.(lp_urb<=0.).OR.(lb_urb<=0.)) then + ws(id)=ws_u(id,iurb) + bs(id)=bs_u(id,iurb) + bs_urb(id,iurb)=bs_u(id,iurb) + ws_urb(id,iurb)=ws_u(id,iurb) + else if ((lp_urb/frc_urb<1.).and.(lp_urb=150.)) then + bs(id)=bs_u(id,iurb) + ws(id)=ws_u(id,iurb) + bs_urb(id,iurb)=bs_u(id,iurb) + ws_urb(id,iurb)=ws_u(id,iurb) + endif + if ((ws(id)<=1.).OR.(ws(id)>=150.)) then + ws(id)=ws_u(id,iurb) + bs(id)=bs_u(id,iurb) + bs_urb(id,iurb)=bs_u(id,iurb) + ws_urb(id,iurb)=ws_u(id,iurb) + endif + enddo return end subroutine param @@ -1642,12 +2121,15 @@ subroutine interpol(kms,kme,kts,kte,nz_u,z,z_u,c,c_u) real c(kms:kme) ! Parameter which has to be interpolated ! Data relative to the "urban grid" integer nz_u ! Number of levels +!! real z_u(nz_u+1) ! Altitude of the cell interface real z_u(nz_um) ! Altitude of the cell interface + ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- - real c_u(nz_um) ! Interpolated paramters in the "urban grid" - +!! real c_u(nz_u) ! Interpolated paramters in the "urban grid" + real c_u(nz_um) ! Interpolated paramters in the "urban grid" + ! LOCAL: ! ---------------------------------------------------------------------- integer iz_u,iz @@ -1672,7 +2154,7 @@ end subroutine interpol ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av,& + subroutine averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av, & sfw_av,sfwind_av,sfw,sfwin) implicit none @@ -1719,7 +2201,7 @@ subroutine averaging_temp(tw,twlev,ss,pb,tw_av,twlev_av,& nbui=ibui endif enddo - + do id=1,ndm do iz=1,nz_um-1 if (pb(iz+1).gt.0) then @@ -1752,10 +2234,10 @@ end subroutine averaging_temp ! ===6=8===============================================================72 subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & - tw,tg,twlev,albg,albw,emw,emg,pwin,albwin, & + tw,tg_av,twlev,albg,albw,emw,emg,pwin,albwin, & emwin,fww,fwg,fgw,fsw,fsg, & - zr,deltar,ah, & - rs,rl,rsw,rsg,rlw,rlg) + zr,deltar,ah,xlat,swddir,swddif, & + rs,rl,rsw,rsd,rsg,rlw,rlg) ! ---------------------------------------------------------------------- ! This routine computes the modification of the short wave and @@ -1778,7 +2260,7 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & real ss(nz_um) ! probability to have a building with height h real pb(nz_um) ! probability to have a building with an height equal real tw(2*ndm,nz_um) ! Temperature in each layer of the wall [K] - real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real tg_av(ndm) ! Temperature in each layer of the ground [K] real albg ! Albedo of the ground for the current urban class real albw ! Albedo of the wall for the current urban class real emg ! Emissivity of ground for the current urban class @@ -1794,6 +2276,10 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & real deltar ! Declination of the sun real rs ! solar radiation real rl ! downward flux of the longwave radiation + real xlat ! latitudine + real swddir ! short wave direct solar radiation _gl + real swddif ! short wave diffuse solar radiation _gl + ! !New variables BEM ! @@ -1809,6 +2295,7 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & real rlw(2*ndm,nz_um) ! Long wave radiation at the walls real rsg(ndm) ! Short wave radiation at the ground real rsw(2*ndm,nz_um) ! Short wave radiation at the walls + real rsd(2*ndm,nz_um) ! Direct Short wave radiation at the walls ! ---------------------------------------------------------------------- ! LOCAL: @@ -1818,28 +2305,32 @@ subroutine modif_rad(iurb,nd,nz_u,z,ws,drst,strd,ss,pb, & ! Calculation of the shadow effects - call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & - rs,rsw,rsg) + call shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & + swddir,rsw,rsg,xlat) + rsd=rsw ! Calculation of the reflection effects do id=1,nd call long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev, & - fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb) + fwg,fww,fgw,fsw,fsg,tg_av,tw,rlg,rlw,rl,pb) alb_av=pwin*albwin+(1.-pwin)*albw - call short_rad(iurb,nz_u,id,alb_av,albg,fwg,fww,fgw,rsg,rsw,pb) - + call short_rad_dd(iurb,nz_u,id,alb_av, & + albg,swddif,fwg,fww,fgw,fsw,fsg,rsg,rsw,pb) + + enddo return end subroutine modif_rad + ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & - tg,alag,csg,emg,albg,ptg,sfg,gfg) + subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & + tg,alag,csg,emg,albg,ptg,sfg,lfg,gfg) ! ---------------------------------------------------------------------- ! Computation of the surface temperatures for walls, ground and roofs @@ -1850,7 +2341,7 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & ! ---------------------------------------------------------------------- ! INPUT: ! ---------------------------------------------------------------------- - + integer nd ! Number of street direction for the current urban class real alag(ng_u) ! Ground thermal diffusivity for the current urban class [m^2 s^-1] @@ -1862,23 +2353,25 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & real emg ! Emissivity of ground for the current urban class real pr(nz_um) ! Air pressure + real rl ! Downward flux of the longwave radiation real rlg(ndm) ! Long wave radiation at the ground + real rsg(ndm) ! Short wave radiation at the ground + real sfg(ndm) ! Sensible heat flux from ground (road) + real lfg(ndm) ! Latent heat flux from ground (road) + real gfg(ndm) ! Heat flux transferred from the surface of the ground (road) toward the interior real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] - - ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- real ptg(ndm) ! Ground potential temperatures - ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- @@ -1888,11 +2381,11 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & real tg_tmp(ng_u) - real dzg_u(ng_u) ! Layer sizes in the ground data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/ + ! ---------------------------------------------------------------------- ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- @@ -1906,10 +2399,13 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & tg_tmp(ig)=tg(id,ig) end do ! +! print*,'alag','cs',alag(1),csg(1) + call soil_temp(ng_u,dzg_u,tg_tmp,ptg(id),alag,csg, & rsg(id),rlg(id),pr(1), & dt,emg,albg, & - rtg(id),sfg(id),gfg(id)) + rtg(id),sfg(id),lfg(id),gfg(id)) + do ig=1,ng_u tg(id,ig)=tg_tmp(ig) end do @@ -1918,16 +2414,198 @@ subroutine surf_temp(nd,pr,dt,rl,rsg,rlg, & return end subroutine surf_temp + + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + + subroutine roof_temp_veg(nd,pr,dt,rl,rsr, & + trv,ptrv,sfrv,lfrv,gfr,qr,rainbl,drain,hfgroof,tr,alar,dzr,csr,nzu,irri_now,gr_type,pv_frac_roof,tpvlev) + +! ---------------------------------------------------------------------- +! Computation of the surface temperatures for walls, ground and roofs +! ---------------------------------------------------------------------- + + implicit none + +! ---------------------------------------------------------------------- +! INPUT: +! ---------------------------------------------------------------------- + real rainbl + integer nd ! Number of street direction for the current urban class + + integer nzu ! Number of urban layers + real irho(24) ! Which hour of irrigation\ + + + real alar ! Roof thermal diffusivity for the current urban class [m^2 s^-1] + real pv_frac_roof + real csr + + real dzr ! Layer sizes in the roofs [m] + + real dt ! Time step + + real pr(nz_um) ! Air pressure + + real rl ! Downward flux of the longwave radiation + + real rsr ! Short wave radiation at the ground + + real tpvlev(ndm,nz_um) + + real sfrv(ndm,nz_um) ! Sensible heat flux from ground (road) + + real lfrv(ndm,nz_um) ! Latent heat flux from ground (road) + + real gfr(ndm,nz_um) ! Heat flux transferred from the surface of the ground (road) toward the interior + + real trv(ndm,nz_um,ngr_u) ! Temperature in each layer of the green roof [K] + + real qr(ndm,nz_um,ngr_u) ! Humidity in each layer of the green roof + + real tr(ndm,nz_um,nwr_u) !Roof temperature in BEM [K] + +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- + real ptrv(ndm,nz_um) ! Ground potential temperatures + + real hfgroof(ndm,nz_um) +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + integer id,ig,ir,iw,iz + + real alagr(ngr_u) ! Green Roof thermal diffusivity for the current urban class [m^2 s^-1] + + real rtr(ndm,nz_um) ! Total radiation at ground(road) surface (solar+incoming long+outgoing long) + + real tr_tmp(ngr_u) + + real qr_tmp(ngr_u) + real qr_tmp_old(ngr_u) + real dzgr_u(ngr_u) ! Layer sizes in the green roof +!MODIFICA + data dzgr_u /0.1,0.003,0.06,0.003,0.05,0.04,0.02,0.0125,0.005,0.0025/ + real cs(ngr_u) ! Specific heat of the ground material + real cw + parameter(cw=4.295e6) + real s(ngr_u) + real d(ngr_u) + real k(ngr_u) + real qr_m ! mean soil moisture between layers + real qrmax(ngr_u) + real smax(ngr_u) + real kmax(ngr_u) + real b(ngr_u) + real cd(ngr_u) + real csa(4) + real ka(4) + real qref + parameter(qref=0.37) + data qrmax /0.0,0.0,0.0,0.0,0.439,0.37,0.37,0.37,0.37,0.37/ + data smax /0,0,0,0,-0.01,-0.1,-0.1,-0.1,-0.1,-0.1/ + data kmax /0,0,0,0,3.32e-3,2.162e-3,2.162e-3,2.162e-3,2.162e-3,2.162e-3/ + data b /0,0,0,0,2.7,3.9,3.9,3.9,3.9,3.9/ + data cd /0,0,0,0,331500,1.342e6,1.342e6,1.342e6,1.342e6,1.342e6/ + data csa /7.5e4,2.1e6,4.48e4,2.1e6/ + data ka /0.035,0.7,0.024,0.7/ + real em_gr(1) + real alb_gr(1) + real irri_now + integer gr_type + real drain(ndm,nz_um) +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS + + if(gr_type.eq.1)then + em_gr=0.95 + alb_gr=0.3 + elseif(gr_type.eq.2)then + em_gr=0.83 + alb_gr=0.154 + endif + + + do iz=2,nzu + + do id=1,nd + + + + +! Calculation for the ground surfaces + + do ig=1,ngr_u + tr_tmp(ig)=trv(id,iz,ig) + qr(id,iz,ig) = max(qr(id,iz,ig),1e-6) !cenlin, 11/4/2020 + qr_tmp(ig)=qr(id,iz,ig) + qr_tmp_old(ig)=qr(id,iz,ig) + + if(ig.le.4) then + + cs(ig)=csa(ig) + alagr(ig)=ka(ig)/csa(ig) + + else + + + if (ig.gt.5) then + qr_m=(qr(id,iz,ig)*dzgr_u(ig-1)+qr(id,iz,ig-1)*dzgr_u(ig))/(dzgr_u(ig)+dzgr_u(ig-1)) + else + qr_m=qr(id,iz,ig) + endif + cs(ig)=(1-qr_m)*cd(ig)+qr_m*cw + s(ig)=smax(ig)*(qrmax(ig)/qr_m)**b(ig) + k(ig)=kmax(ig)*(qr_m/qrmax(ig))**(2*b(ig)+3) + d(ig)=-b(ig)*kmax(ig)*smax(ig)*((qr_m/qrmax(ig))**(b(ig)+3))/qr_m + if (log10(abs(s(ig))).le.5.1) then + alagr(ig)=exp(-(log10(abs(s(ig)))+2.7))*4.186e2/cs(ig) + endif + if (log10(abs(s(ig))).gt.5.1) then + alagr(ig)=0.00041*4.186e2/cs(ig) + endif + + endif + + end do + hfgroof(id,iz)=(alar/csr+alagr(1))*(tr_tmp(1)-tr(id,iz,5))/(dzr+dzgr_u(1)) + + call soil_temp_veg(hfgroof(id,iz),ngr_u,dzgr_u,tr_tmp,ptrv(id,iz),alagr,cs, & + rsr,rl,pr(iz), & + dt,em_gr(1),alb_gr(1), & + rtr(id,iz),sfrv(id,iz),lfrv(id,iz),gfr(id,iz),pv_frac_roof,tpvlev(id,iz)) + do ig=1,ngr_u + trv(id,iz,ig)=tr_tmp(ig) + end do + drain(id,iz)=kmax(5)*(qr(id,iz,5)/qrmax(5))**(2*b(5)+3) + call soil_moist(ngr_u,dzgr_u,qr_tmp,dt,lfrv(id,iz),d,k,rainbl,drain(id,iz),irri_now) + + do ig=1,ngr_u + ! qr(id,iz,ig)=min(qr_tmp(ig),qrmax(ig)) + qr(id,iz,ig)=max(min(qr_tmp(ig),qrmax(ig)),1e-6) !cenlin,11/4/2020 + end do + + end do !id + end do !iz + + return + end subroutine roof_temp_veg + ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & - ptg,ptr,da_u,ptw,ptwin,pwin, & + subroutine buildings(iurb,nd,nz,z0,cdrag,ua_u,va_u,pt_u,pt0_u, & + ptg,ptr,ptrv,da_u,qv_u,pr_u,tmp_u,ptw,ptwin,pwin, & drst,uva_u,vva_u,uvb_u,vvb_u, & tva_u,tvb_u,evb_u,qvb_u,qhb_u, & - uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr, & - sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac) + uhb_u,vhb_u,thb_u,ehb_u,ss,dt,sfw,sfg,sfr,sfrpv,sfrv,lfrv, & + dgr,dg,lfr,lfg, & + sfwin,pb,bs_u,dz_u,sflev,lflev,sfvlev,lfvlev,tvb_ac,ix,iy,rsg,rs,qr,gr_frac_roof, & + pv_frac_roof,gr_flag,gr_type) ! ---------------------------------------------------------------------- ! This routine computes the sources or sinks of the different quantities @@ -1942,23 +2620,34 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & ! INPUT: ! ---------------------------------------------------------------------- integer nd ! Number of street direction for the current urban class + integer ix,iy integer nz ! number of vertical space steps real ua_u(nz_um) ! Wind speed in the x direction on the urban grid real va_u(nz_um) ! Wind speed in the y direction on the urban grid real da_u(nz_um) ! air density on the urban grid + real qv_u(nz_um) ! specific humidity on the urban grid + real pr_u(nz_um) ! pressure on the urban grid + real tmp_u(nz_um) ! temperaure on the urban grid real drst(ndm) ! Street directions for the current urban class real dz real pt_u(nz_um) ! Potential temperature on the urban grid real pt0_u(nz_um) ! reference potential temperature on the urban grid real ptg(ndm) ! Ground potential temperatures real ptr(ndm,nz_um) ! Roof potential temperatures + real ptrv(ndm,nz_um) ! Green Roof potential temperatures real ptw(2*ndm,nz_um,nbui_max) ! Walls potential temperatures real ss(nz_um) ! probability to have a building with height h real pb(nz_um) + real cdrag(nz_um) real z0(ndm,nz_um) ! Roughness lengths "profiles" real dt ! time step integer iurb !Urban class - + real rsg(ndm) ! Solar Radiation + real rs ! Solar Radiation + real qr(ndm,nz_um,ngr_u) ! Ground Soil Moisture + real trv(ndm,nz_um,ngr_u) ! Ground Soil Moisture + real roof_frac + real road_frac ! !New variables (BEM) ! @@ -1973,6 +2662,10 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & real ptwin(2*ndm,nz_um,nbui_max) ! window potential temperature real pwin real tvb_ac(2*ndm,nz_um) + real gr_frac_roof + real pv_frac_roof + integer gr_flag,gr_type + ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- @@ -1992,11 +2685,22 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & real tvb_u(2*ndm,nz_um) ! Temperature Vertical surfaces, B (explicit) term real ehb_u(ndm,nz_um) ! Energy (TKE) Horizontal surfaces, B (explicit) term real evb_u(2*ndm,nz_um) ! Energy (TKE) Vertical surfaces, B (explicit) term + real uhb(2*ndm,nz_um) + real vhb(2*ndm,nz_um) + real ehb(2*ndm,nz_um) real sfw(2*ndm,nz_um,nbui_max) ! sensible heat flux from walls real sfwin(2*ndm,nz_um,nbui_max) ! sensible heat flux form windows real sfr(ndm,nz_um) ! sensible heat flux from roof + real sfrv(ndm,nz_um) ! sensible heat flux from roof + real lfrv(ndm,nz_um) ! Latent heat flux from roof + real dgr(ndm,nz_um) ! sensible heat flux from roof + real dg(ndm) + real lfr(ndm,nz_um) ! Latent heat flux from roof + real lfg(ndm) ! Latent heat flux from street + real sfrpv(ndm,nz_um) ! sensible heat flux from PV panels real sfg(ndm) ! sensible heat flux from street + ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- @@ -2007,9 +2711,22 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & real vvb_tmp real evb_tmp integer nlev(nz_um) - integer id,iz,ibui,nbui - -! ---------------------------------------------------------------------- + integer id,iz,ibui,nbui,il + real wfg !Ground water pool fraction + real wfr !Roof water pool fraction + real uhbv(2*ndm,nz_um) + real vhbv(2*ndm,nz_um) + real ehbv(2*ndm,nz_um) + real z0v !Vegetation roughness + parameter(z0v=0.01) + real resg + real rsveg + real f1,f2,f3,f4 + integer rsv(2) + real qr_tmp(ngr_u) + data rsv /0,1/ + real fh,ric,utot +!------------------------------------------------------------------ ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- dz=dz_u @@ -2031,44 +2748,88 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & evb_u=0. qvb_u=0. qhb_u=0. + + uhb=0. + vhb=0. + ehb=0. + uhbv=0. + vhbv=0. + ehbv=0. + do iz=1,nz_um - if(ss(iz).gt.0) then + if(ss(iz).gt.0)then ibui=ibui+1 d_urb(ibui)=ss(iz) nlev(ibui)=iz-1 nbui=ibui endif enddo - if (nbui.gt.nbui_max) then - write(*,*) 'nbui_max must be increased to',nbui - stop - endif - do id=1,nd ! Calculation at the ground surfaces - - call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1), & - ptg(id),uhb_u(id,1), & - vhb_u(id,1),sfg(id),ehb_u(id,1),da_u(1)) - thb_u(id,1)=- sfg(id)/(da_u(1)*cp_u) - -! Calculation at the roof surfaces - + do id=1,nd + + call flux_flat(dz,z0(id,1),ua_u(1),va_u(1),pt_u(1),pt0_u(1), & + ptg(id),qv_u(1),uhb(id,1), & + vhb(id,1),sfg(id),lfg(id),ehb(id,1),da_u(1),pr_u(1)) + if(dg(id).gt.0)then + wfg=dg(id)/dgmax + lfg(id)=-da_u(1)*latent*(-(wfg*lfg(id))/(da_u(1)*latent)) + else + qhb_u(id,1)=0. + lfg(id)=0. + endif + thb_u(id,1)=-(sfg(id))/(da_u(1)*cp_u) + vhb_u(id,1)=vhb(id,1) + uhb_u(id,1)=uhb(id,1) + ehb_u(id,1)=ehb(id,1) + qhb_u(id,1)=-lfg(id)/(da_u(1)*latent) do iz=2,nz if(ss(iz).gt.0)then - call flux_flat(dz,z0(id,iz),ua_u(iz), & - va_u(iz),pt_u(iz),pt0_u(iz), & - ptr(id,iz),uhb_u(id,iz), & - vhb_u(id,iz),sfr(id,iz),ehb_u(id,iz),da_u(iz)) - thb_u(id,iz)=- sfr(id,iz)/(da_u(iz)*cp_u) - else - uhb_u(id,iz) = 0.0 - vhb_u(id,iz) = 0.0 - thb_u(id,iz) = 0.0 - ehb_u(id,iz) = 0.0 + + call flux_flat(dz,z0(id,iz),ua_u(iz),& + va_u(iz),pt_u(iz),pt0_u(iz), & + ptr(id,iz),qv_u(iz),uhb(id,iz), & + vhb(id,iz),sfr(id,iz),lfr(id,iz),ehb(id,iz),da_u(iz),pr_u(iz)) + if(dgr(id,iz).gt.0)then + wfr=dgr(id,iz)/drmax + lfr(id,iz)=-da_u(iz)*latent*(-(wfr*lfr(id,iz))/(da_u(iz)*latent)) + else + lfr(id,iz)=0. + endif + if(gr_flag.eq.1.and.gr_frac_roof.gt.0.)then + do il=1,ngr_u + qr_tmp(il)=qr(id,iz,il) + enddo + call flux_flat_roof(dz,z0v,ua_u(iz),va_u(iz),pt_u(iz),pt0_u(iz), & + ptrv(id,iz),uhbv(id,iz), & + vhbv(id,iz),sfrv(id,iz),lfrv(id,iz),ehbv(id,iz),da_u(iz),qv_u(iz),pr_u(iz),rs,qr_tmp,resg,rsveg,f1,f2,f3,f4,gr_type,pv_frac_roof) + sfr(id,iz)=sfr(id,iz)+pv_frac_roof*sfrpv(id,iz) + thb_u(id,iz)=-((1.-gr_frac_roof)*sfr(id,iz)+gr_frac_roof*sfrv(id,iz))/(da_u(iz)*cp_u) + vhb_u(id,iz)=(1.-gr_frac_roof)*vhb(id,iz)+gr_frac_roof*vhbv(id,iz) + uhb_u(id,iz)=(1.-gr_frac_roof)*uhb(id,iz)+gr_frac_roof*uhbv(id,iz) + ehb_u(id,iz)=(1.-gr_frac_roof)*ehb(id,iz)+gr_frac_roof*ehbv(id,iz) + qhb_u(id,iz)=-(gr_frac_roof*lfrv(id,iz)+(1.-gr_frac_roof)*lfr(id,iz))/(da_u(iz)*latent) + sfr(id,iz)=sfr(id,iz)-pv_frac_roof*sfrpv(id,iz) + else + sfr(id,iz)=sfr(id,iz)+pv_frac_roof*sfrpv(id,iz) + thb_u(id,iz)=-sfr(id,iz)/(da_u(iz)*cp_u) + vhb_u(id,iz)=vhb(id,iz) + uhb_u(id,iz)=uhb(id,iz) + ehb_u(id,iz)=ehb(id,iz) + qhb_u(id,iz)=-lfr(id,iz)/(da_u(iz)*latent) + sfr(id,iz)=sfr(id,iz)-pv_frac_roof*sfrpv(id,iz) + endif + else + uhb_u(id,iz) = 0.0 + vhb_u(id,iz) = 0.0 + thb_u(id,iz) = 0.0 + ehb_u(id,iz) = 0.0 + qhb_u(id,iz) = 0.0 endif - end do + enddo + + ! Calculation at the wall surfaces @@ -2080,7 +2841,7 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & uva_tmp,vva_tmp, & uvb_tmp,vvb_tmp, & sfw(2*id-1,iz,ibui),sfwin(2*id-1,iz,ibui), & - evb_tmp,drst(id),dt) + evb_tmp,drst(id),dt,cdrag(iz)) if (pb(iz+1).gt.0.) then @@ -2105,7 +2866,7 @@ subroutine buildings(iurb,nd,nz,z0,ua_u,va_u,pt_u,pt0_u, & uva_tmp,vva_tmp, & uvb_tmp,vvb_tmp, & sfw(2*id,iz,ibui),sfwin(2*id,iz,ibui), & - evb_tmp,drst(id),dt) + evb_tmp,drst(id),dt,cdrag(iz)) if (pb(iz+1).gt.0.) then @@ -2360,7 +3121,7 @@ end subroutine urban_meso ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine interp_length(nd,kms,kme,kts,kte,nz_u,z_u,z,ss,ws,bs, & + subroutine interp_length(nd,kms,kme,kts,kte,nz_u,z_u,z,ss,ws,bs, & dlg,dl_u) ! ---------------------------------------------------------------------- @@ -2446,7 +3207,7 @@ end subroutine interp_length ! ===6=8===============================================================72 subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & - rs,rsw,rsg) + swddir,rsw,rsg,xlat) ! ---------------------------------------------------------------------- ! Modification of short wave radiation to take into account @@ -2463,13 +3224,14 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & real ah ! Hour angle (it should come from the radiation routine) real deltar ! Declination of the sun real drst(ndm) ! street directions for the current urban class - real rs ! solar radiation + real swddir ! solar radiation real ss(nz_um) ! probability to have a building with height h real pb(nz_um) ! Probability that a building has an height greater or equal to h real ws(ndm) ! Street width of the current urban class real z(nz_um) ! Height of the urban grid levels real zr ! zenith angle - + real xlat + real xlat_r ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- @@ -2486,23 +3248,29 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & ! END VARIABLES DEFINITIONS ! ---------------------------------------------------------------------- - if(rs.eq.0.or.sin(zr).eq.1)then - do id=1,nd - rsg(id)=0. - do iz=1,nz_u + xlat_r=xlat*pi/180 + + if(swddir.eq.0.or.sin(zr).eq.1)then + do id=1,nd + rsg(id)=0. + do iz=1,nz_u rsw(2*id-1,iz)=0. rsw(2*id,iz)=0. enddo enddo - else + else !test - if(abs(sin(zr)).gt.1.e-10)then + + if(abs(sin(zr)).gt.1.e-10)then if(cos(deltar)*sin(ah)/sin(zr).ge.1)then bbb=pi/2. elseif(cos(deltar)*sin(ah)/sin(zr).le.-1)then bbb=-pi/2. else - bbb=asin(cos(deltar)*sin(ah)/sin(zr)) + bbb=asin(cos(deltar)*sin(ah)/sin(zr)) ! + if(sin(deltar).lt.(cos(zr)*sin(xlat_r)))then ! + bbb=pi-bbb ! + endif endif else if(cos(deltar)*sin(ah).ge.0)then @@ -2511,58 +3279,63 @@ subroutine shadow_mas(nd,nz_u,zr,deltar,ah,drst,ws,ss,pb,z, & bbb=-pi/2. endif endif - - phix=zr + phix=zr do id=1,nd - + rsg(id)=0. - + aae=bbb-drst(id) aaw=bbb-drst(id)+pi - + do iz=1,nz_u rsw(2*id-1,iz)=0. - rsw(2*id,iz)=0. - if (pb(iz+1).gt.0.) then - do jz=1,nz_u + rsw(2*id,iz)=0. + if(pb(iz+1).gt.0.)then + do jz=1,nz_u if(abs(sin(aae)).gt.1.e-10)then - call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, & - ws(id),rd) - rsw(2*id-1,iz)=rsw(2*id-1,iz)+rs*rd*ss(jz+1)/pb(iz+1) + call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aae, & + ws(id),rd) + rsw(2*id-1,iz)=rsw(2*id-1,iz)+swddir*rd*ss(jz+1)/pb(iz+1) endif - + if(abs(sin(aaw)).gt.1.e-10)then - call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, & + call shade_wall(z(iz),z(iz+1),z(jz+1),phix,aaw, & ws(id),rd) - rsw(2*id,iz)=rsw(2*id,iz)+rs*rd*ss(jz+1)/pb(iz+1) + rsw(2*id,iz)=rsw(2*id,iz)+swddir*rd*ss(jz+1)/pb(iz+1) endif - enddo - endif + enddo + endif enddo if(abs(sin(aae)).gt.1.e-10)then wsd=abs(ws(id)/sin(aae)) - - do jz=1,nz_u + + do jz=1,nz_u rd=max(0.,wsd-z(jz+1)*tan(phix)) - rsg(id)=rsg(id)+rs*rd*ss(jz+1)/wsd + rsg(id)=rsg(id)+swddir*rd*ss(jz+1)/wsd enddo rtot=0. - + do iz=1,nz_u rtot=rtot+(rsw(2*id,iz)+rsw(2*id-1,iz))* & (z(iz+1)-z(iz)) enddo rtot=rtot+rsg(id)*ws(id) else - rsg(id)=rs + rsg(id)=swddir endif + + enddo endif return end subroutine shadow_mas + + + + ! ===6=8===============================================================72 ! ===6=8===============================================================72 @@ -2623,7 +3396,7 @@ end subroutine shade_wall ! ===6=8===============================================================72 subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& - fwg,fww,fgw,fsw,fsg,tg,tw,rlg,rlw,rl,pb) + fwg,fww,fgw,fsw,fsg,tg_av,tw,rlg,rlw,rl,pb) ! ---------------------------------------------------------------------- ! This routine computes the effects of the reflections of long-wave @@ -2653,7 +3426,7 @@ subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& integer nz_u ! Number of layer in the urban grid real pb(nz_um) ! Probability to have a building with an height equal real rl ! Downward flux of the longwave radiation - real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real tg_av(ndm) ! Temperature in each layer of the ground [K] real tw(2*ndm,nz_um) ! Temperature in each layer of the wall [K] ! !New Variables for BEM @@ -2696,9 +3469,10 @@ subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1) enddo +!! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb)*pb(i+1) aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i,id,iurb) - bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg(id,ng_u)**4 + bbb(i)=fsw(i,id,iurb)*rl+emg*fgw(i,id,iurb)*sigma*tg_av(id)**4 do j=1,nz_u bbb(i)=bbb(i)+pb(j+1)*sigma*fww(j,i,id,iurb)* & (emw*(1.-pwin)*tw(2*id,j)**4+emwin*pwin*twlev(2*id,j)**4)+ & @@ -2721,10 +3495,11 @@ subroutine long_rad(iurb,nz_u,id,emw,emg,emwin,pwin,twlev,& aaa(i,i)=1. +!! aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb)*pb(i-nz_u+1) aaa(i,2*nz_u+1)=-(1.-emg)*fgw(i-nz_u,id,iurb) bbb(i)=fsw(i-nz_u,id,iurb)*rl+ & - emg*fgw(i-nz_u,id,iurb)*sigma*tg(id,ng_u)**4 + emg*fgw(i-nz_u,id,iurb)*sigma*tg_av(id)**4 do j=1,nz_u bbb(i)=bbb(i)+pb(j+1)*sigma*fww(j,i-nz_u,id,iurb)* & @@ -2776,8 +3551,9 @@ end subroutine long_rad ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine short_rad(iurb,nz_u,id,albw, & - albg,fwg,fww,fgw,rsg,rsw,pb) + + subroutine short_rad_dd(iurb,nz_u,id,albw, & + albg,rsdif,fwg,fww,fgw,fsw,fsg,rsg,rsw,pb) ! ---------------------------------------------------------------------- ! This routine computes the effects of the reflections of short-wave @@ -2797,9 +3573,12 @@ subroutine short_rad(iurb,nz_u,id,albw, & ! ---------------------------------------------------------------------- real albg ! Albedo of the ground for the current urban class real albw ! Albedo of the wall for the current urban class + real rsdif ! diffused short wave radiation real fgw(nz_um,ndm,nurbm) ! View factors from ground to wall real fwg(nz_um,ndm,nurbm) ! View factors from wall to ground real fww(nz_um,nz_um,ndm,nurbm) ! View factors from wall to wall + real fsg(ndm,nurbm) ! View factors from sky to ground + real fsw(nz_um,ndm,nurbm) ! View factors from sky to wall integer id ! current street direction integer iurb ! current urban class integer nz_u ! Number of layer in the urban grid @@ -2825,67 +3604,69 @@ subroutine short_rad(iurb,nz_u,id,albw, & ! west wall - do i=1,nz_u + + do i=1,nz_u do j=1,nz_u aaa(i,j)=0. enddo - - aaa(i,i)=1. - + + aaa(i,i)=1. + do j=nz_u+1,2*nz_u aaa(i,j)=-albw*fww(j-nz_u,i,id,iurb)*pb(j-nz_u+1) enddo - + aaa(i,2*nz_u+1)=-albg*fgw(i,id,iurb) - bbb(i)=rsw(2*id-1,i) - + bbb(i)=rsw(2*id-1,i)+fsw(i,id,iurb)*rsdif + enddo - + ! east wall - - do i=1+nz_u,2*nz_u + do i=1+nz_u,2*nz_u do j=1,nz_u aaa(i,j)=-albw*fww(j,i-nz_u,id,iurb)*pb(j+1) enddo - + do j=1+nz_u,2*nz_u aaa(i,j)=0. enddo - + aaa(i,i)=1. aaa(i,2*nz_u+1)=-albg*fgw(i-nz_u,id,iurb) - bbb(i)=rsw(2*id,i-nz_u) - + bbb(i)=rsw(2*id,i-nz_u)+fsw(i-nz_u,id,iurb)*rsdif + enddo -! ground +! ground do j=1,nz_u aaa(2*nz_u+1,j)=-albw*fwg(j,id,iurb)*pb(j+1) enddo - + do j=nz_u+1,2*nz_u aaa(2*nz_u+1,j)=-albw*fwg(j-nz_u,id,iurb)*pb(j-nz_u+1) enddo - + aaa(2*nz_u+1,2*nz_u+1)=1. - bbb(2*nz_u+1)=rsg(id) - + bbb(2*nz_u+1)=rsg(id)+fsg(id,iurb)*rsdif + call gaussj(aaa,2*nz_u+1,bbb,2*nz_um+1) do i=1,nz_u rsw(2*id-1,i)=bbb(i) enddo - + do i=nz_u+1,2*nz_u - rsw(2*id,i-nz_u)=bbb(i) + rsw(2*id,i-nz_u)=bbb(i) enddo - + rsg(id)=bbb(2*nz_u+1) + return - end subroutine short_rad - + end subroutine short_rad_dd + + ! ===6=8===============================================================72 ! ===6=8===============================================================72 @@ -2993,12 +3774,101 @@ subroutine gaussj(a,n,b,np) return end subroutine gaussj + + + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine soil_moist(nz,dz,qv,dt,lf,d,k,rainbl,drain,irri_now) + +! ---------------------------------------------------------------------- +! This routine solves the Fourier diffusion equation for heat in +! the material (wall, roof, or ground). Resolution is done implicitely. +! Boundary conditions are: +! - fixed temperature at the interior +! - energy budget at the surface +! ---------------------------------------------------------------------- + + implicit none + + + +! ---------------------------------------------------------------------- +! INPUT: +! ---------------------------------------------------------------------- + integer nz ! Number of layers + real dt ! Time step + real lf ! Latent heat flux at the surface + real qv(nz) ! Moisture in each layer [K] + real dz(nz) ! Layer sizes [m] + real rainbl ! Rainfall [mm] + real d(nz) ! Soil water diffusivity + real k(nz) ! Hydraulic conductivity + real gr ! Dummy variable + real drain + real irri_now +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- + + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + integer iz + real a(nz,3) + real alpha + real c(nz) + real cddz(nz+2) + real dw !water density Kg/m3 + parameter(dw=1000.) +!---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS +! ---------------------------------------------------------------------- + + alpha=rainbl/(dw*dt)+lf/latent/dw+irri_now/dw + cddz(1)=0. + do iz=2,nz + cddz(iz)=2.*d(iz)/(dz(iz)+dz(iz-1)) + enddo + do iz=1,4 + a(iz,1)=0. + a(iz,2)=1. + a(iz,3)=0. + c(iz)=qv(iz) + enddo + do iz=6,nz-1 + a(iz,1)=-cddz(iz)*dt/dz(iz) + a(iz,2)=1.+dt*(cddz(iz)+cddz(iz+1))/dz(iz) + a(iz,3)=-cddz(iz+1)*dt/dz(iz) + c(iz)=qv(iz)+dt*(k(iz+1)-k(iz))/dz(iz) + enddo + a(5,1)=0. + a(5,2)=1.+dt*(cddz(5+1))/dz(5) + a(5,3)=-cddz(5+1)*dt/dz(5) + c(5)=qv(5)+dt*(k(5+1)-drain)/dz(5) + + + a(nz,1)=-dt*cddz(nz)/dz(nz) + a(nz,2)=1.+dt*cddz(nz)/dz(nz) + a(nz,3)=0. + c(nz)=qv(nz)+dt*alpha/dz(nz)-dt*k(nz-1)/dz(nz) + + call invert(nz,a,c,qv) + + return + end subroutine soil_moist +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine soil_temp(nz,dz,temp,pt,ala,cs, & - rs,rl,press,dt,em,alb,rt,sf,gf) + subroutine soil_temp_veg(heflro,nz,dz,temp,pt,ala,cs, & + rs,rl,press,dt,em,alb,rt,sf,lf,gf,pv_frac_roof,tpv) ! ---------------------------------------------------------------------- ! This routine solves the Fourier diffusion equation for heat in @@ -3025,9 +3895,107 @@ subroutine soil_temp(nz,dz,temp,pt,ala,cs, & real rl ! Downward flux of the longwave radiation real rs ! Solar radiation real sf ! Sensible heat flux at the surface + real lf ! Latent heat flux at the surface real temp(nz) ! Temperature in each layer [K] real dz(nz) ! Layer sizes [m] + real heflro ! Heat flux between roof and green roof + real rs_eff + real rl_eff + real tpv + real pv_frac_roof +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- + real gf ! Heat flux transferred from the surface toward the interior + real pt ! Potential temperature at the surface + real rt ! Total radiation at the surface (solar+incoming long+outgoing long) + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + integer iz + real a(nz,3) + real alpha + real c(nz) + real cddz(nz+2) + real tsig + +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS +! ---------------------------------------------------------------------- + if(pv_frac_roof.gt.0)then + rl_eff=(1-pv_frac_roof)*em*rl+em*sigma*tpv**4*pv_frac_roof + rs_eff=(1.-pv_frac_roof)*rs + else + rl_eff=em*rl + rs_eff=rs + endif + tsig=temp(nz) + alpha=(1.-alb)*rs_eff+rl_eff-em*sigma*(tsig**4)+sf+lf + cddz(1)=ala(1)/dz(1) + do iz=2,nz + cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1)) + enddo + + a(1,1)=0. + a(1,2)=1. + a(1,3)=0. + c(1)=temp(1)-heflro*dt/dz(1) + do iz=2,nz-1 + a(iz,1)=-cddz(iz)*dt/dz(iz) + a(iz,2)=1.+dt*(cddz(iz)+cddz(iz+1))/dz(iz) + a(iz,3)=-cddz(iz+1)*dt/dz(iz) + c(iz)=temp(iz) + enddo + a(nz,1)=-dt*cddz(nz)/dz(nz) + a(nz,2)=1.+dt*cddz(nz)/dz(nz) + a(nz,3)=0. + c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz) + + call invert(nz,a,c,temp) + + pt=temp(nz)*(press/1.e+5)**(-rcp_u) + + rt=(1.-alb)*rs_eff+rl_eff-em*sigma*(tsig**4.) + + gf=(1.-alb)*rs_eff+rl_eff-em*sigma*(tsig**4.)+sf + return + end subroutine soil_temp_veg + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine soil_temp(nz,dz,temp,pt,ala,cs, & + rs,rl,press,dt,em,alb,rt,sf,lf,gf) +! ---------------------------------------------------------------------- +! This routine solves the Fourier diffusion equation for heat in +! the material (wall, roof, or ground). Resolution is done implicitely. +! Boundary conditions are: +! - fixed temperature at the interior +! - energy budget at the surface +! ---------------------------------------------------------------------- + + implicit none + + + +! ---------------------------------------------------------------------- +! INPUT: +! ---------------------------------------------------------------------- + integer nz ! Number of layers + real ala(nz) ! Thermal diffusivity in each layers [m^2 s^-1] + real alb ! Albedo of the surface + real cs(nz) ! Specific heat of the material [J m^3 K^-1] + real dt ! Time step + real em ! Emissivity of the surface + real press ! Pressure at ground level + real rl ! Downward flux of the longwave radiation + real rs ! Solar radiation + real sf ! Sensible heat flux at the surface + real lf ! Latent heat flux at the surface + real temp(nz) ! Temperature in each layer [K] + real dz(nz) ! Layer sizes [m] ! ---------------------------------------------------------------------- ! OUTPUT: @@ -3051,46 +4019,44 @@ subroutine soil_temp(nz,dz,temp,pt,ala,cs, & ! ---------------------------------------------------------------------- tsig=temp(nz) - alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf + alpha=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf+lf ! Compute cddz=2*cd/dz - cddz(1)=ala(1)/dz(1) do iz=2,nz cddz(iz)=2.*ala(iz)/(dz(iz)+dz(iz-1)) enddo - + a(1,1)=0. a(1,2)=1. a(1,3)=0. c(1)=temp(1) - do iz=2,nz-1 a(iz,1)=-cddz(iz)*dt/dz(iz) - a(iz,2)=1+dt*(cddz(iz)+cddz(iz+1))/dz(iz) + a(iz,2)=1.+dt*(cddz(iz)+cddz(iz+1))/dz(iz) a(iz,3)=-cddz(iz+1)*dt/dz(iz) c(iz)=temp(iz) enddo - a(nz,1)=-dt*cddz(nz)/dz(nz) a(nz,2)=1.+dt*cddz(nz)/dz(nz) a(nz,3)=0. - c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz) + c(nz)=temp(nz)+dt*alpha/cs(nz)/dz(nz) call invert(nz,a,c,temp) - pt=temp(nz)*(press/1.e+5)**(-rcp_u) - rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4) + rt=(1.-alb)*rs+em*rl-em*sigma*(tsig**4.) - gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4)+sf + gf=(1.-alb)*rs+em*rl-em*sigma*(tsig**4.)+sf return end subroutine soil_temp + ! ===6=8===============================================================72 ! ===6=8===============================================================72 + subroutine invert(n,a,c,x) ! ---------------------------------------------------------------------- @@ -3144,7 +4110,7 @@ end subroutine invert ! ===6=8===============================================================72 subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb, & - sfw,sfwin,evb,drst,dt) + sfw,sfwin,evb,drst,dt,cdrag) ! ---------------------------------------------------------------------- ! This routine computes the surface sources or sinks of momentum, tke, @@ -3162,7 +4128,7 @@ subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb, & real ua ! wind speed real va ! wind speed real dt !time step - + real cdrag ! OUTPUT: ! ------ ! Explicit and implicit component of the momentum, temperature and TKE sources or sinks on @@ -3174,8 +4140,8 @@ subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb, & real uvb ! U (wind component) Vertical surfaces, B (explicit) term real vva ! V (wind component) Vertical surfaces, A (implicit) term real vvb ! V (wind component) Vertical surfaces, B (explicit) term -! real tva ! Temperature Vertical surfaces, A (implicit) term -! real tvb ! Temperature Vertical surfaces, B (explicit) term + real tva ! Temperature Vertical surfaces, A (implicit) term + real tvb ! Temperature Vertical surfaces, B (explicit) term real evb ! Energy (TKE) Vertical surfaces, B (explicit) term real sfw ! Surfaces fluxes from the walls real sfwin ! Surfaces fluxes from the windows @@ -3188,59 +4154,451 @@ subroutine flux_wall(ua,va,pt,da,ptw,ptwin,uva,vva,uvb,vvb, & real vett -! ------------------------- -! END VARIABLES DEFINITIONS -! ------------------------- +! ------------------------- +! END VARIABLES DEFINITIONS +! ------------------------- + + vett=(ua**2+va**2)**.5 + + u_ort=abs((cos(drst)*ua-sin(drst)*va)) + + uva=-cdrag*u_ort/2.*cos(drst)*cos(drst) + vva=-cdrag*u_ort/2.*sin(drst)*sin(drst) + + uvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*va + vvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*ua + + if (vett.lt.4.88) then + hc=5.678*(1.09+0.23*(vett/0.3048)) + else + hc=5.678*0.53*((vett/0.3048)**0.78) + endif + + if (hc.gt.da*cp_u/dt)then + hc=da*cp_u/dt + endif + + if (vett.lt.4.88) then + hcwin=5.678*(0.99+0.21*(vett/0.3048)) + else + hcwin=5.678*0.50*((vett/0.3048)**0.78) + endif + + if (hcwin.gt.da*cp_u/dt) then + hcwin=da*cp_u/dt + endif + +! tvb=hc*ptw/da/cp_u +! tva=-hc/da/cp_u +!!!!!!!!!!!!!!!!!!!! +! explicit + + sfw=hc*(pt-ptw) + sfwin=hcwin*(pt-ptwin) + + + evb=cdrag*(abs(u_ort)**3.)/2. + + return + end subroutine flux_wall + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + subroutine flux_flat_ground(dz,z0,ua,va,pt,pt0,ptg, & + uhb,vhb,sf,ehb,da,qv,pr,rsg,qg,resg,rsveg,f1,f2,f3,f4,fh,ric,utot,gr_type) + +! ---------------------------------------------------------------------- +! Calculation of the flux at the ground +! Formulation of Louis (Louis, 1979) +! ---------------------------------------------------------------------- + + implicit none + + real dz ! first vertical level + real pt ! potential temperature + real pt0 ! reference potential temperature + real ptg ! ground potential temperature + real ua ! wind speed + real va ! wind speed + real z0 ! Roughness length + real da ! air density + real qv ! specific humidity + real pr ! pressure + real rsg ! solar radiation + real qg(ng_u) ! Ground Soil Moisture + + + +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- +! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal +! surfaces (roofs and street) +! The fluxes can be computed as follow: Fluxes of X = B +! Example: Momentum fluxes on horizontal surfaces = uhb_u + real uhb ! U (wind component) Horizontal surfaces, B (explicit) term + real vhb ! V (wind component) Horizontal surfaces, B (explicit) term +! real thb ! Temperature Horizontal surfaces, B (explicit) term + real tva ! Temperature Vertical surfaces, A (implicit) term + real tvb ! Temperature Vertical surfaces, B (explicit) term + real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term + real sf + real lf + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + real aa,ah + real z0t + real al + real buu + real c + real fbuw + real fbpt + real fh + real fm + real ric + real tstar + real qstar + real ustar + real utot + real wstar + real zz + real qvsg,qvs,es,esa,fbqq + real b,cm,ch,rr,tol + parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001) + + real f + real f1 + real f2 + real f3 + real f4 + real ta ! surface air temperature + real tmp ! ground temperature + real rsveg ! Stomatal resistance + real resg + real lai ! leaf area index + real sdlim ! radiation limit at which photosyntesis start W/m2 + parameter(sdlim=100.) + real rsmin ! Minimum stomatal resistance + real rsmax ! Maximun stomatal resistance + real qw + parameter(qw=0.06) + real qref + parameter(qref=0.37) + real hs + parameter(hs=36.35) + + real dzg_u(ng_u) ! Layer sizes in the ground + + data dzg_u /0.2,0.12,0.08,0.05,0.03,0.02,0.02,0.01,0.005,0.0025/ + + real gx,dzg_tot + integer gr_type,iz +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS +! ---------------------------------------------------------------------- + z0t=z0/10. + if(gr_type.eq.1)then + rsmin=40. + rsmax=5000. + lai=2. + elseif(gr_type.eq.2)then + rsmin=150. + rsmax=5000. + lai=3. + endif +! computation of the ground temperature + + utot=(ua**2.+va**2.)**.5 + + +!!!! Louis formulation +! +! compute the bulk Richardson Number + + zz=dz/2. + +! if(tstar.lt.0.)then +! wstar=(-ustar*tstar*g*hii/pt)**(1./3.) +! else +! wstar=0. +! endif +! +! if (utot.le.0.7*wstar) utot=max(0.7*wstar,0.00001) + + utot=max(utot,0.01) + + ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2)) + + aa=vk/log(zz/z0) + ah=vk/log(zz/z0t) + +! determine the parameters fm and fh for stable, neutral and unstable conditions + + if(ric.gt.0)then + fm=1/(1+0.5*b*ric)**2. + fh=fm + else + c=b*cm*aa*aa*(zz/z0)**.5 + fm=1-b*ric/(1+c*(-ric)**.5) + c=b*cm*aa*ah*(zz/z0t)**.5 + c=c*ch/cm + fh=1-b*ric/(1+c*(-ric)**.5) + endif + + fbuw=-aa*aa*utot*utot*fm + fbpt=-aa*ah*utot*(pt-ptg)*fh/rr + tmp=ptg*(pr/p0)**(rcp_u)-273.15 + es=6.11*(10.**(tmp*7.5/(237.7+tmp))) + qvsg=0.62197*es/(0.01*pr-0.378*es) + + + f=0.55*rsg/sdlim*2./lai + + f1=(f+rsmin/rsmax)/(1.+f) + + ta=pt*(pr/p0)**(rcp_u)-273.15 + esa=6.11*(10**(ta*7.5/(237.7+ta))) + qvs=0.62197*esa/(0.01*pr-0.378*esa) + + f2= 1./(1.+hs*(qvs-qv)) + f3=1.-0.0016*(25.-ta)**2. + f4=0. + dzg_tot=0. + do iz=1,ng_u + gx=(qg(iz)-qw)/(qref-qw) + if (gx.gt.1)gx=1. + if (gx.lt.0)gx=0. + f4=f4+gx*dzg_u(iz) + dzg_tot=dzg_tot+dzg_u(iz) + enddo + f4=f4/dzg_tot + + rsveg=min(rsmin/max(lai*f1*f2*f3*f4,1e-9),rsmax) + resg= rr/(aa*aa*utot*fh) + + + fbqq=-(qv-qvsg)/(resg+rsveg) + + + ustar=(-fbuw)**.5 + tstar=-fbpt/ustar + qstar=-fbqq/ustar + + al=(vk*g_u*tstar)/(pt*ustar*ustar) + + buu=-g_u/pt0*ustar*tstar + + uhb=-ustar*ustar*ua/utot + vhb=-ustar*ustar*va/utot + sf= ustar*tstar*da*cp_u + lf= ustar*qstar*da*latent + +! thb= 0. + ehb=buu +!!!!!!!!!!!!!!! + + return + end subroutine flux_flat_ground + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + subroutine flux_flat_roof(dz,z0,ua,va,pt,pt0,ptg, & + uhb,vhb,sf,lf,ehb,da,qv,pr,rsg,qr,resg,rsveg,f1,f2,f3,f4,gr_type,pv_frac_roof) + +! ---------------------------------------------------------------------- +! Calculation of the flux at the ground +! Formulation of Louis (Louis, 1979) +! ---------------------------------------------------------------------- + + implicit none + + real dz ! first vertical level + real pt ! potential temperature + real pt0 ! reference potential temperature + real ptg ! ground potential temperature + real ua ! wind speed + real va ! wind speed + real z0 ! Roughness length + real da ! air density + real qv ! specific humidity + real pr ! pressure + real rsg ! solar radiation + real qr(ngr_u) ! Ground Soil Moisture + real pv_frac_roof + real rs_eff + +! ---------------------------------------------------------------------- +! OUTPUT: +! ---------------------------------------------------------------------- +! Explicit component of the momentum, temperature and TKE sources or sinks on horizontal +! surfaces (roofs and street) +! The fluxes can be computed as follow: Fluxes of X = B +! Example: Momentum fluxes on horizontal surfaces = uhb_u + real uhb ! U (wind component) Horizontal surfaces, B (explicit) term + real vhb ! V (wind component) Horizontal surfaces, B (explicit) term +! real thb ! Temperature Horizontal surfaces, B (explicit) term + real tva ! Temperature Vertical surfaces, A (implicit) term + real tvb ! Temperature Vertical surfaces, B (explicit) term + real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term + real sf + real lf + +! ---------------------------------------------------------------------- +! LOCAL: +! ---------------------------------------------------------------------- + real aa,ah + real al + real buu + real c + real fbuw + real fbpt + real fh + real fm + real ric + real tstar + real qstar + real ustar + real utot + real wstar + real zz + real z0t + real qvsg,qvs,es,esa,fbqq + real b,cm,ch,rr,tol + parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001) + + real f + real f1 + real f2 + real f3 + real f4 + real ta ! surface air temperature + real tmp ! ground temperature + real rsveg ! Stomatal resistance + real resg + real lai ! leaft area index + real sdlim ! radiation limit at which photosyntesis start W/m2 + parameter(sdlim=100.) + real rsmin + real rsmax ! Maximun stomatal resistance + real qw ! Wilting point + parameter(qw=0.06) + real qref ! Field capacity + parameter(qref=0.37) + real hs + parameter(hs=36.35) + + real dzgr_u(ngr_u) ! Layer sizes in the ground + + data dzgr_u /0.1,0.003,0.06,0.003,0.05,0.04,0.02,0.0125,0.005,0.0025/ + + real gx,dzgr_tot + integer gr_type,iz +! ---------------------------------------------------------------------- +! END VARIABLES DEFINITIONS + +! ---------------------------------------------------------------------- + z0t=z0/10. + if(gr_type.eq.1)then + rsmin=40. + rsmax=5000. + lai=2. + elseif(gr_type.eq.2)then + rsmin=150. + rsmax=5000. + lai=3. + endif + rs_eff=(1-pv_frac_roof)*rsg +! computation of the ground temperature + + utot=(ua**2.+va**2.)**.5 + +!!!! Louis formulation +! +! compute the bulk Richardson Number + + zz=dz/2. + + + utot=max(utot,0.01) + + ric=2.*g_u*zz*(pt-ptg)/((pt+ptg)*(utot**2)) + + aa=vk/log(zz/z0) + ah=vk/log(zz/z0t) + + if(ric.gt.0.)then + fm=1./(1.+0.5*b*ric)**2. + fh=fm + else + c=b*cm*aa*aa*(zz/z0)**.5 + fm=1.-b*ric/(1.+c*(-ric)**.5) + c=b*cm*aa*ah*(zz/z0t)**.5 + c=c*ch/cm + fh=1.-b*ric/(1+c*(-ric)**.5) + endif + + fbuw=-aa*aa*utot*utot*fm + fbpt=-aa*ah*utot*(pt-ptg)*fh/rr + tmp=ptg*(pr/p0)**(rcp_u)-273.15 + es=6.11*(10.**(tmp*7.5/(237.7+tmp))) + qvsg=0.62197*es/(0.01*pr-0.378*es) + + + f=0.55*rs_eff/sdlim*2./lai + + f1=(f+rsmin/rsmax)/(1.+f) + + ta=pt*(pr/p0)**(rcp_u)-273.15 + esa=6.11*(10**(ta*7.5/(237.7+ta))) + qvs=0.62197*esa/(0.01*pr-0.378*esa) + + f2= 1./(1.+hs*(qvs-qv)) + f3=1.-0.0016*(25.-ta)**2. + f4=0. + dzgr_tot=0. + do iz=5,ngr_u + gx=(qr(iz)-qw)/(qref-qw) + if (gx.gt.1)gx=1. + if (gx.lt.0)gx=0. + f4=f4+gx*dzgr_u(iz) + dzgr_tot=dzgr_tot+dzgr_u(iz) + enddo + f4=f4/dzgr_tot + + rsveg=min(rsmin/max(lai*f1*f2*f3*f4,1e-9),rsmax) + + + resg= rr/(aa*aa*utot*fh) - vett=(ua**2+va**2)**.5 - - u_ort=abs((cos(drst)*ua-sin(drst)*va)) - - uva=-cdrag*u_ort/2.*cos(drst)*cos(drst) - vva=-cdrag*u_ort/2.*sin(drst)*sin(drst) - - uvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*va - vvb=cdrag*u_ort/2.*sin(drst)*cos(drst)*ua - if (vett.lt.4.88) then - hc=5.678*(1.09+0.23*(vett/0.3048)) - else - hc=5.678*0.53*((vett/0.3048)**0.78) - endif + fbqq=-(qv-qvsg)/(resg+rsveg) - if (hc.gt.da*cp_u/dt)then - hc=da*cp_u/dt - endif + ustar=(-fbuw)**.5 + tstar=-fbpt/ustar + qstar=-fbqq/ustar - if (vett.lt.4.88) then - hcwin=5.678*(0.99+0.21*(vett/0.3048)) - else - hcwin=5.678*0.50*((vett/0.3048)**0.78) - endif + al=(vk*g_u*tstar)/(pt*ustar*ustar) - if (hcwin.gt.da*cp_u/dt) then - hcwin=da*cp_u/dt - endif - -! tvb=hc*ptw/da/cp_u -! tva=-hc/da/cp_u -!!!!!!!!!!!!!!!!!!!! -! explicit + buu=-g_u/pt0*ustar*tstar + + uhb=-ustar*ustar*ua/utot + vhb=-ustar*ustar*va/utot + sf= ustar*tstar*da*cp_u + lf= ustar*qstar*da*latent + + ehb=buu + end subroutine flux_flat_roof + +!!!!!!!=============================== - sfw=hc*(pt-ptw) - sfwin=hcwin*(pt-ptwin) - - - evb=cdrag*(abs(u_ort)**3.)/2. - - return - end subroutine flux_wall - ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & - uhb,vhb,sf,ehb,da) + subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg,qv, & + uhb,vhb,sf,lf,ehb,da,pr) ! ---------------------------------------------------------------------- ! Calculation of the flux at the ground @@ -3248,7 +4606,7 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & ! ---------------------------------------------------------------------- implicit none - + real pr real dz ! first vertical level real pt ! potential temperature real pt0 ! reference potential temperature @@ -3257,9 +4615,7 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & real va ! wind speed real z0 ! Roughness length real da ! air density - - - + real qv ! ---------------------------------------------------------------------- ! OUTPUT: ! ---------------------------------------------------------------------- @@ -3270,12 +4626,12 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & real uhb ! U (wind component) Horizontal surfaces, B (explicit) term real vhb ! V (wind component) Horizontal surfaces, B (explicit) term ! real thb ! Temperature Horizontal surfaces, B (explicit) term -! real tva ! Temperature Vertical surfaces, A (implicit) term -! real tvb ! Temperature Vertical surfaces, B (explicit) term + real tva ! Temperature Vertical surfaces, A (implicit) term + real tvb ! Temperature Vertical surfaces, B (explicit) term real ehb ! Energy (TKE) Horizontal surfaces, B (explicit) term real sf - - + real lf + ! ---------------------------------------------------------------------- ! LOCAL: ! ---------------------------------------------------------------------- @@ -3290,10 +4646,11 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & real ric real tstar real ustar + real qstar real utot real wstar real zz - + real qvsg,qvs,es,esa,fbqq,tmp,resg real b,cm,ch,rr,tol parameter(b=9.4,cm=7.4,ch=5.3,rr=0.74,tol=.001) @@ -3320,86 +4677,66 @@ subroutine flux_flat(dz,z0,ua,va,pt,pt0,ptg, & aa=vk/log(zz/z0) + + + tmp=ptg*(pr/(1.e+5))**(rcp_u)-273.15 + es=6.11*(10**(tmp*7.5/(237.7+tmp))) + qvsg=0.62197*es/(0.01*pr-0.378*es) + + + ! determine the parameters fm and fh for stable, neutral and unstable conditions - if(ric.gt.0)then - fm=1/(1+0.5*b*ric)**2 + if(ric.gt.0.)then + fm=1./(1.+0.5*b*ric)**2 fh=fm else c=b*cm*aa*aa*(zz/z0)**.5 - fm=1-b*ric/(1+c*(-ric)**.5) + fm=1.-b*ric/(1.+c*(-ric)**.5) c=c*ch/cm - fh=1-b*ric/(1+c*(-ric)**.5) + fh=1.-b*ric/(1.+c*(-ric)**.5) endif - + + resg= rr/(aa*aa*utot*fh) fbuw=-aa*aa*utot*utot*fm fbpt=-aa*aa*utot*(pt-ptg)*fh/rr - + fbqq=-(qv-qvsg)/(resg) + ustar=(-fbuw)**.5 tstar=-fbpt/ustar - + qstar=-fbqq/ustar al=(vk*g_u*tstar)/(pt*ustar*ustar) buu=-g_u/pt0*ustar*tstar uhb=-ustar*ustar*ua/utot vhb=-ustar*ustar*va/utot - sf= ustar*tstar*da*cp_u - -! thb= 0. + sf= ustar*tstar*da*cp_u + lf= ustar*qstar*da*latent ehb=buu !!!!!!!!!!!!!!! return end subroutine flux_flat - +!!!!!!!!!!!!!================!!!!!!!!!!!!!!!!!!! ! ===6=8===============================================================72 ! ===6=8===============================================================72 - subroutine icBEP (fww,fwg,fgw,fsw,fws,fsg, & - z0g_u,z0r_u, & - nd_u,strd_u,ws_u,bs_u,h_b,d_b,ss_u,pb_u, & - nz_u,z_u) - - - implicit none - - -! Building parameters - -! Radiation parameters + subroutine icBEP (nd_u,h_b,d_b,ss_u,pb_u,nz_u,z_u) -! Roughness parameters - real z0g_u(nurbm) ! The ground's roughness length - real z0r_u(nurbm) ! The roof's roughness length + implicit none ! Street parameters integer nd_u(nurbm) ! Number of street direction for each urban class - - real strd_u(ndm,nurbm) ! Street length (fix to greater value to the horizontal length of the cells) - real ws_u(ndm,nurbm) ! Street width [m] - real bs_u(ndm,nurbm) ! Building width [m] real h_b(nz_um,nurbm) ! Bulding's heights [m] real d_b(nz_um,nurbm) ! The probability that a building has an height h_b ! ----------------------------------------------------------------------- ! Output !------------------------------------------------------------------------ - - -! fww,fwg,fgw,fsw,fsg are the view factors used to compute the long wave -! and the short wave radation. They are the part of radiation from a surface -! or from the sky to another surface. - real fww(nz_um,nz_um,ndm,nurbm) ! from wall to wall - real fwg(nz_um,ndm,nurbm) ! from wall to ground - real fgw(nz_um,ndm,nurbm) ! from ground to wall - real fsw(nz_um,ndm,nurbm) ! from sky to wall - real fws(nz_um,ndm,nurbm) ! from wall to sky - real fsg(ndm,nurbm) ! from sky to ground - real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to z real pb_u(nz_um,nurbm) ! The probability that a building has an height greater or equal to z - + ! Grid parameters integer nz_u(nurbm) ! Number of layer in the urban grid real z_u(nz_um) ! Height of the urban grid levels @@ -3414,34 +4751,26 @@ subroutine icBEP (fww,fwg,fgw,fsw,fws,fsg, & real dtot real hbmax -!------------------------------------------------------------------------ - - ! ----------------------------------------------------------------------- ! This routine initialise the urban paramters for the BEP module !------------------------------------------------------------------------ ! -!Initialize some variables +!Initialize variables ! - nz_u=0 - z_u=0. - ss_u=0. - pb_u=0. - fww=0. - fwg=0. - fgw=0. - fsw=0. - fws=0. - fsg=0. + ! + nz_u=0 + z_u=0. + ss_u=0. + pb_u=0. ! Computation of the urban levels height z_u(1)=0. - + do iz_u=1,nz_um-1 z_u(iz_u+1)=z_u(iz_u)+dz_u enddo - + ! Normalisation of the building density do iurb=1,nurbm @@ -3452,37 +4781,33 @@ subroutine icBEP (fww,fwg,fgw,fsw,fws,fsg, & do ilu=1,nz_um d_b(ilu,iurb)=d_b(ilu,iurb)/dtot enddo - enddo + enddo -! Compute the view factors, pb and ss - - do iurb=1,nurbm +! Compute the view factors, pb and ss + + do iurb=1,nurbm hbmax=0. nz_u(iurb)=0 do ilu=1,nz_um if(h_b(ilu,iurb).gt.hbmax)hbmax=h_b(ilu,iurb) enddo - + do iz_u=1,nz_um-1 if(z_u(iz_u+1).gt.hbmax)go to 10 enddo - + 10 continue - nz_u(iurb)=iz_u+1 + nz_u(iurb)=iz_u+1 do id=1,nd_u(iurb) - call view_factors(iurb,nz_u(iurb),id,strd_u(id,iurb), & - z_u,ws_u(id,iurb), & - fww,fwg,fgw,fsg,fsw,fws) - do iz_u=1,nz_u(iurb) ss_u(iz_u,iurb)=0. do ilu=1,nz_um - if(z_u(iz_u).le.h_b(ilu,iurb) & - .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then + if(z_u(iz_u).le.h_b(ilu,iurb) & + .and.z_u(iz_u+1).gt.h_b(ilu,iurb))then ss_u(iz_u,iurb)=ss_u(iz_u,iurb)+d_b(ilu,iurb) - endif + endif enddo enddo @@ -3493,13 +4818,14 @@ subroutine icBEP (fww,fwg,fgw,fsw,fws,fsg, & enddo end do - - - return + + + return end subroutine icBEP ! ===6=8===============================================================72 ! ===6=8===============================================================72 + subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws) @@ -3617,7 +4943,7 @@ subroutine view_factors(iurb,nz_u,id,dxy,z,ws,fww,fwg,fgw,fsg,fsw,fws) enddo ! radiation from wall to sky - do iz=1,nz_u + do iz=1,nz_u call fnrms(fnrm,ws,dxy,hut-z(iz)) f12=fnrm call fnrms(fnrm,ws,dxy,hut-z(iz+1)) @@ -3665,6 +4991,7 @@ end subroutine view_factors ! ===6=8===============================================================72 ! ===6=8===============================================================72 + SUBROUTINE fprls (fprl,a,b,c) implicit none @@ -3726,16 +5053,19 @@ SUBROUTINE fnrms (fnrm,a,b,c) end subroutine fnrms ! ===6=8===============================================================72 - SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& + SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& twini_u,trini_u,tgini_u,albg_u,albw_u,albr_u,albwin_u,emg_u,emw_u,& - emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b, & - cop_u, pwin_u, beta_u, sw_cond_u, time_on_u, time_off_u, & - targtemp_u, gaptemp_u, targhum_u, gaphum_u, perflo_u, hsesf_u, hsequip) + emr_u,emwind_u,z0g_u,z0r_u,nd_u,strd_u,drst_u,ws_u,bs_u,h_b,d_b, & + cop_u,pwin_u,beta_u,sw_cond_u,time_on_u,time_off_u,targtemp_u, & + bldac_frc_u,cooled_frc_u, & + gaptemp_u, targhum_u,gaphum_u,perflo_u, & + gr_frac_roof_u,pv_frac_roof_u, & + hsesf_u,hsequip,irho,gr_flag_u,gr_type_u) + ! initialization routine, where the variables from the table are read implicit none - integer iurb ! urban class number ! Building parameters real alag_u(nurbm) ! Ground thermal diffusivity [m^2 s^-1] @@ -3774,7 +5104,8 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& integer i,iu integer nurb ! number of urban classes used - + real, intent(out) :: bldac_frc_u(nurbm) + real, intent(out) :: cooled_frc_u(nurbm) real, intent(out) :: cop_u(nurbm) real, intent(out) :: pwin_u(nurbm) real, intent(out) :: beta_u(nurbm) @@ -3786,14 +5117,18 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& real, intent(out) :: targhum_u(nurbm) real, intent(out) :: gaphum_u(nurbm) real, intent(out) :: perflo_u(nurbm) + real, intent(out) :: gr_frac_roof_u(nurbm) + real, intent(out) :: pv_frac_roof_u(nurbm) real, intent(out) :: hsesf_u(nurbm) real, intent(out) :: hsequip(24) - + real, intent(out) :: irho(24) + integer, intent(out) :: gr_flag_u,gr_type_u ! -!We initialize -! - h_b=0. - d_b=0. +!Initialize some variables +! + + h_b=0. + d_b=0. nurb=ICATE do iu=1,nurb @@ -3820,7 +5155,10 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& z0r_u=Z0R_TBL z0g_u=Z0G_TBL nd_u=NUMDIR_TBL -!MT BEM +!FS + ! print*, 'g alla call', gr_frac_roof_u(iurb) + bldac_frc_u = bldac_frc_tbl + cooled_frc_u = cooled_frc_tbl cop_u = cop_tbl pwin_u = pwin_tbl beta_u = beta_tbl @@ -3832,12 +5170,16 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& targhum_u = targhum_tbl gaphum_u = gaphum_tbl perflo_u = perflo_tbl + gr_frac_roof_u =gr_frac_roof_tbl + gr_flag_u=gr_flag_tbl + pv_frac_roof_u = pv_frac_roof_tbl hsesf_u = hsesf_tbl hsequip = hsequip_tbl - + irho=irho_tbl + gr_type_u=gr_type_tbl do iu=1,icate if(ndm.lt.nd_u(iu))then - write(*,*)'ndm too small in module_sf_bep, please increase to at least ', nd_u(iu) + write(*,*)'ndm too small in module_sf_bep_bem, please increase to at least ', nd_u(iu) write(*,*)'remember also that num_urban_layers should be equal or greater than nz_um*ndm*nwr-u!' stop endif @@ -3872,14 +5214,17 @@ SUBROUTINE init_para(alag_u,alaw_u,alar_u,csg_u,csw_u,csr_u,& return end subroutine init_para -! ===6================================================================72 -! ===6================================================================72 - subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & - tg,emg_u,albg_u,rlg,rsg,sfg, & - tw,emw_u,albw_u,rlw,rsw,sfw, & - tr,emr_u,albr_u,emwind,albwind,twlev,pwin, & - sfwind,rld,rs, sfr, & - rs_abs,rl_up,emiss,grdflx_urb) +!============================================================== +!============================================================== +!====6=8===============================================================72 +!====6=8===============================================================72 + + subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss, & + tg_av,emg_u,albg_u,rlg,rsg,sfg,lfg, & + tw,emw_u,albw_u,rlw,rsw,sfw, & + tr_av,emr_u,albr_u,emwind,albwind,twlev,pwin, & + sfwind,rld,rs, sfr,sfrv,lfr,lfrv, & + rs_abs,rl_up,emiss,grdflx_urb,gr_frac_roof,tpvlev,pv_frac_roof) ! ! IN this surboutine we compute the upward longwave flux, and the albedo ! needed for the radiation scheme @@ -3893,11 +5238,16 @@ subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & real rlw(2*ndm,nz_um) ! Long wave radiation at the walls for a given canyon direction [W/m2] real rsg(ndm) ! Short wave radiation at the canyon for a given canyon direction [W/m2] real rlg(ndm) ! Long wave radiation at the ground for a given canyon direction [W/m2] - real rs ! Short wave radiation at the horizontal surface from the sun [W/m²] - real sfw(2*ndm,nz_um) ! Sensible heat flux from walls [W/m²] - real sfg(ndm) ! Sensible heat flux from ground (road) [W/m²] - real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/m²] - real rld ! Long wave radiation from the sky [W/m²] + real rs ! Short wave radiation at the horizontal surface from the sun [W/m2] + real sfw(2*ndm,nz_um) ! Sensible heat flux from walls [W/m2] + real sfg(ndm) ! Sensible heat flux from ground (road) [W/m2] + real lfg(ndm) + real sfr(ndm,nz_um) ! Sensible heat flux from roofs [W/m2] + real lfr(ndm,nz_um) + real lfrv(ndm,nz_um) + real sfrv(ndm,nz_um) + real gr_frac_roof + real rld ! Long wave radiation from the sky [W/m2] real albg_u ! albedo of the ground/street real albw_u ! albedo of the walls real albr_u ! albedo of the roof @@ -3905,17 +5255,19 @@ subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & real bs(ndm) ! building size real pb(nz_um) ! Probability to have a building with an height equal or higher - integer nz_u + integer nzu real ss(nz_um) ! Probability to have a building of a given height real sigma real emg_u ! emissivity of the street real emw_u ! emissivity of the wall real emr_u ! emissivity of the roof real tw(2*ndm,nz_um) ! Temperature in each layer of the wall [K] - real tr(ndm,nz_um,nwr_u) ! Temperature in each layer of the roof [K] - real tg(ndm,ng_u) ! Temperature in each layer of the ground [K] + real tr_av(ndm,nz_um) ! Temperature in each layer of the roof [K] + real tpvlev(ndm,nz_um) + real pv_frac_roof + real tg_av(ndm) ! Temperature in each layer of the ground [K] integer id ! street direction - integer nd_u ! number of street directions + integer ndu ! number of street directions ! !New variables BEM ! @@ -3924,7 +5276,7 @@ subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & real twlev(2*ndm,nz_um) !Averaged Temperature of the windows real pwin !Coverage area fraction of the windows real gflwin !Heat stored for the windows - real sfwind(2*ndm,nz_um) !Sensible heat flux from windows [W/m²] + real sfwind(2*ndm,nz_um) !Sensible heat flux from windows [W/m2] !OUTPUT/INPUT real rs_abs ! absrobed solar radiationfor this street direction @@ -3938,14 +5290,13 @@ subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & integer ix,iy,iwrong iwrong=1 - do iz=1,nz_u+1 - do id=1,nd_u - do iw=1,nwr_u - if(tr(id,iz,iw).lt.100.)then - write(*,*)'in upward_rad ',iz,id,iw,tr(id,iz,iw) + do iz=1,nzu+1 + do id=1,ndu + if(tr_av(id,iz).lt.100.)then + write(203,*) tr_av(id,iz) + write(*,*)'in upward_rad ',iz,id,iw,tr_av(id,iz) iwrong=0 - endif - enddo + endif enddo enddo if(iwrong.eq.0)stop @@ -3957,32 +5308,34 @@ subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & emiss=0. rl_emit=0. grdflx_urb=0. - do id=1,nd_u - rl_emit=rl_emit-( emg_u*sigma*(tg(id,ng_u)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/nd_u - rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/nd_u - rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/nd_u - gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg(id,ng_u)**4.)+sfg(id) - grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/nd_u + do id=1,ndu + rl_emit=rl_emit-( emg_u*sigma*(tg_av(id)**4.)+(1-emg_u)*rlg(id))*ws(id)/(ws(id)+bs(id))/ndu + rl_inc=rl_inc+rlg(id)*ws(id)/(ws(id)+bs(id))/ndu + rs_abs=rs_abs+(1.-albg_u)*rsg(id)*ws(id)/(ws(id)+bs(id))/ndu + gfl=(1.-albg_u)*rsg(id)+emg_u*rlg(id)-emg_u*sigma*(tg_av(id)**4.)+sfg(id)+lfg(id) + grdflx_urb=grdflx_urb-gfl*ws(id)/(ws(id)+bs(id))/ndu - do iz=2,nz_u - rl_emit=rl_emit-(emr_u*sigma*(tr(id,iz,nwr_u)**4.)+(1-emr_u)*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u - rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u - rs_abs=rs_abs+(1.-albr_u)*rs*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u - gfl=(1.-albr_u)*rs+emr_u*rld-emr_u*sigma*(tr(id,iz,nwr_u)**4.)+sfr(id,iz) - grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/nd_u + do iz=2,nzu + rl_emit=rl_emit-(emr_u*sigma*(1.-pv_frac_roof)*tr_av(id,iz)**4.+0.79*sigma*pv_frac_roof*tpvlev(id,iz)**4+ & + (1-emr_u)*rld*(1.-pv_frac_roof)+(1-0.79)*pv_frac_roof*rld)*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + rl_inc=rl_inc+rld*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + rs_abs=rs_abs+((1.-albr_u)*rs*(1.-pv_frac_roof)+(1.-0.11)*rs*pv_frac_roof)*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu + gfl=(1.-albr_u)*rs*(1-pv_frac_roof)+emr_u*rld*(1-pv_frac_roof)+pv_frac_roof*emr_u*sigma*tpvlev(id,iz)**4 & + -emr_u*sigma*(tr_av(id,iz)**4.)+(1-gr_frac_roof)*sfr(id,iz)+(sfrv(id,iz)+lfrv(id,iz))*gr_frac_roof+(1.-gr_frac_roof)*lfr(id,iz) + grdflx_urb=grdflx_urb-gfl*ss(iz)*bs(id)/(ws(id)+bs(id))/ndu enddo - do iz=1,nz_u + do iz=1,nzu rl_emit=rl_emit-(emw_u*(1.-pwin)*sigma*(tw(2*id-1,iz)**4.+tw(2*id,iz)**4.)+ & (emwind*pwin*sigma*(twlev(2*id-1,iz)**4.+twlev(2*id,iz)**4.))+ & ((1.-emw_u)*(1.-pwin)+pwin*(1.-emwind))*(rlw(2*id-1,iz)+rlw(2*id,iz)))* & - dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u + dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu - rl_inc=rl_inc+((rlw(2*id-1,iz)+rlw(2*id,iz)))*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u + rl_inc=rl_inc+((rlw(2*id-1,iz)+rlw(2*id,iz)))*dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu rs_abs=rs_abs+(((1.-albw_u)*(1.-pwin)+(1.-albwind)*pwin)*(rsw(2*id-1,iz)+rsw(2*id,iz)))*& - dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u + dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu gfl=(1.-albw_u)*(rsw(2*id-1,iz)+rsw(2*id,iz)) +emw_u*( rlw(2*id-1,iz)+rlw(2*id,iz) ) & -emw_u*sigma*( tw(2*id-1,iz)**4.+tw(2*id,iz)**4. )+(sfw(2*id-1,iz)+sfw(2*id,iz)) @@ -3991,7 +5344,7 @@ subroutine upward_rad(nd_u,nz_u,ws,bs,sigma,pb,ss, & -emwind*sigma*( twlev(2*id-1,iz)**4.+twlev(2*id,iz)**4.)+(sfwind(2*id-1,iz)+sfwind(2*id,iz)) - grdflx_urb=grdflx_urb-(gfl*(1.-pwin)+pwin*gflwin)*dz_u*pb(iz+1)/(ws(id)+bs(id))/nd_u + grdflx_urb=grdflx_urb-(gfl*(1.-pwin)+pwin*gflwin)*dz_u*pb(iz+1)/(ws(id)+bs(id))/ndu enddo @@ -4105,4 +5458,253 @@ subroutine foncs(fonc,x,aa,bb,cc,alf,delt,gam) end subroutine foncs !====================================================================72 !====================================================================72 + + subroutine icBEP_XY(iurb,fww_u,fwg_u,fgw_u,fsw_u, & + fws_u,fsg_u,ndu,strd,ws,nzu,z_u) + + implicit none + +! Street parameters + integer ndu ! Number of street direction for each urban class + integer iurb + + real strd(ndm) ! Street length (fix to greater value to the horizontal length of the cells) + real ws(ndm) ! Street width [m] + +! Grid parameters + integer nzu ! Number of layer in the urban grid + real z_u(nz_um) ! Height of the urban grid levels +! ----------------------------------------------------------------------- +! Output +!------------------------------------------------------------------------ + +! fww_u,fwg_u,fgw_u,fsw_u,fsg_u are the view factors used to compute the long wave +! and the short wave radation. They are the part of radiation from a surface +! or from the sky to another surface. + + real fww_u(nz_um,nz_um,ndm,nurbm) ! from wall to wall + real fwg_u(nz_um,ndm,nurbm) ! from wall to ground + real fgw_u(nz_um,ndm,nurbm) ! from ground to wall + real fsw_u(nz_um,ndm,nurbm) ! from sky to wall + real fws_u(nz_um,ndm,nurbm) ! from sky to wall + real fsg_u(ndm,nurbm) ! from sky to ground + +! ----------------------------------------------------------------------- +! Local +!------------------------------------------------------------------------ + + integer id + +! ----------------------------------------------------------------------- +! This routine compute the view factors +!------------------------------------------------------------------------ +! +!Initialize +! + fww_u=0. + fwg_u=0. + fgw_u=0. + fsw_u=0. + fws_u=0. + fsg_u=0. + + do id=1,ndu + + call view_factors(iurb,nzu,id,strd(id),z_u,ws(id), & + fww_u,fwg_u,fgw_u,fsg_u,fsw_u,fws_u) + + enddo + return + end subroutine icBEP_XY +!====================================================================72 +!====================================================================72 + subroutine icBEPHI_XY(iurb,hb_u,hi_urb1D,ss_u,pb_u,nzu,z_u) + + implicit none +!----------------------------------------------------------------------- +! Inputs +!----------------------------------------------------------------------- +! Street parameters +! + real hi_urb1D(nz_um) ! The probability that a building has an height h_b + integer iurb ! Number of the urban class +! +! Grid parameters +! + real z_u(nz_um) ! Height of the urban grid levels +! ----------------------------------------------------------------------- +! Output +!------------------------------------------------------------------------ + + real ss_u(nz_um,nurbm) ! The probability that a building has an height equal to z + real pb_u(nz_um) ! The probability that a building has an height greater or equal to z +! +! Grid parameters +! + integer nzu ! Number of layer in the urban grid + +! ----------------------------------------------------------------------- +! Local +!------------------------------------------------------------------------ + real hb_u(nz_um) ! Bulding's heights [m] + integer iz_u,id,ilu + + real dtot + real hbmax + +!------------------------------------------------------------------------ + +!Initialize variables +! + + nzu=0 + ss_u=0. + pb_u=0. + +! Normalisation of the building density + + dtot=0. + hb_u=0. + + do ilu=1,nz_um + dtot=dtot+hi_urb1D(ilu) + enddo + + do ilu=1,nz_um + if (hi_urb1D(ilu)<0.) then +! write(*,*) 'WARNING, HI_URB1D(ilu) < 0 IN BEP_BEM' + go to 20 + endif + enddo + + if (dtot.gt.0.) then + continue + else +! write(*,*) 'WARNING, HI_URB1D <= 0 IN BEP_BEM' + go to 20 + endif + + do ilu=1,nz_um + hi_urb1D(ilu)=hi_urb1D(ilu)/dtot + enddo + + hb_u(1)=dz_u + do ilu=2,nz_um + hb_u(ilu)=dz_u+hb_u(ilu-1) + enddo + + +! Compute pb and ss + + + hbmax=0. + + do ilu=1,nz_um + if (hi_urb1D(ilu)>0.and.hi_urb1D(ilu)<=1.) then + hbmax=hb_u(ilu) + endif + enddo + + do iz_u=1,nz_um-1 + if(z_u(iz_u+1).gt.hbmax)go to 10 + enddo + +10 continue + + nzu=iz_u+1 + + if ((nzu+1).gt.nz_um) then + write(*,*) 'error, nz_um has to be increased to at least',nzu+1 + stop + endif + + do iz_u=1,nzu + ss_u(iz_u,iurb)=0. + do ilu=1,nz_um + if(z_u(iz_u).le.hb_u(ilu) & + .and.z_u(iz_u+1).gt.hb_u(ilu))then + ss_u(iz_u,iurb)=ss_u(iz_u,iurb)+hi_urb1D(ilu) + endif + enddo + enddo + + pb_u(1)=1. + do iz_u=1,nzu + pb_u(iz_u+1)=max(0.,pb_u(iz_u)-ss_u(iz_u,iurb)) + enddo + +20 continue + return + end subroutine icBEPHI_XY +!====================================================================72 +!====================================================================72 END MODULE module_sf_bep_bem + +! ===6=8===============================================================72 +! ===6=8===============================================================72 + + FUNCTION bep_bem_nurbm () RESULT (bep_bem_val_nurbm) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nurbm + bep_bem_val_nurbm = nurbm + END FUNCTION bep_bem_nurbm + + FUNCTION bep_bem_ndm () RESULT (bep_bem_val_ndm) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ndm + bep_bem_val_ndm = ndm + END FUNCTION bep_bem_ndm + + FUNCTION bep_bem_nz_um () RESULT (bep_bem_val_nz_um) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nz_um + bep_bem_val_nz_um = nz_um + END FUNCTION bep_bem_nz_um + + FUNCTION bep_bem_ng_u () RESULT (bep_bem_val_ng_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ng_u + bep_bem_val_ng_u = ng_u + END FUNCTION bep_bem_ng_u + + FUNCTION bep_bem_nwr_u () RESULT (bep_bem_val_nwr_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nwr_u + bep_bem_val_nwr_u = nwr_u + END FUNCTION bep_bem_nwr_u + + FUNCTION bep_bem_nf_u () RESULT (bep_bem_val_nf_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nf_u + bep_bem_val_nf_u = nf_u + END FUNCTION bep_bem_nf_u + + + FUNCTION bep_bem_ngb_u () RESULT (bep_bem_val_ngb_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ngb_u + bep_bem_val_ngb_u = ngb_u + END FUNCTION bep_bem_ngb_u + + FUNCTION bep_bem_nbui_max () RESULT (bep_bem_val_nbui_max) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_nbui_max + bep_bem_val_nbui_max = nbui_max + END FUNCTION bep_bem_nbui_max + + + FUNCTION bep_bem_ngr_u () RESULT (bep_bem_val_ngr_u) + USE module_sf_bep_bem + IMPLICIT NONE + INTEGER :: bep_bem_val_ngr_u + bep_bem_val_ngr_u = ngr_u + END FUNCTION bep_bem_ngr_u + 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/module_sf_noah_seaice.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F new file mode 100644 index 0000000000..9e3a048b79 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice.F @@ -0,0 +1,1295 @@ +!================================================================================================================= +MODULE module_sf_noah_seaice + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_constants,only: cp,R_D=>R_d,XLF,XLV,RHOWATER=>rho_w,STBOLT +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#else +use module_model_constants, only : CP, R_D, XLF, XLV, RHOWATER, STBOLT +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#endif + use module_sf_noahlsm, only : RD, SIGMA, CPH2O, CPICE, LSUBF, EMISSI_S, & + & HSTEP + + PUBLIC SFLX_SEAICE + PRIVATE CSNOW + PRIVATE HRTICE + PRIVATE PENMAN + PRIVATE SHFLX + PRIVATE SNOPAC + PRIVATE SNOWPACK + PRIVATE SNOWZ0 + PRIVATE SNOW_NEW + + INTEGER, PRIVATE :: ILOC + INTEGER, PRIVATE :: JLOC +!$omp threadprivate(iloc, jloc) + + REAL, PARAMETER, PRIVATE :: TFREEZ = 273.15 +! +CONTAINS +! + SUBROUTINE SFLX_SEAICE (IILOC, JJLOC, SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, & !C + & SEAICE_SNOWDEPTH_OPT, SEAICE_SNOWDEPTH_MAX, & !C + & SEAICE_SNOWDEPTH_MIN, & !C + & FFROZP,DT,ZLVL,NSOIL, & !C + & SITHICK, & + & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2, & !F + & TH2,Q2SAT,DQSDT2, & !I + & SNOALB,TBOT, Z0BRD, Z0, EMISSI, & !S + & T1,STC,SNOWH,SNEQV,ALBEDO, CH, & !H + & ALBEDOSI, SNOWONSI, & + & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O + & ESNOW,DEW,ETP,SSOIL,FLX1,FLX2,FLX3, & !O + & SNOMLT,SNCOVR, & !O + & RUNOFF1,Q1,RIBB) + +! ---------------------------------------------------------------------- +! SUBROUTINE SFLX_SEAICE +! ---------------------------------------------------------------------- +! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A SEA-ICE +! LAND-SURFACE MODEL TO UPDATE ICE TEMPERATURE, SKIN TEMPERATURE, +! SNOWPACK WATER CONTENT, SNOWDEPTH, AND ALL TERMS OF THE SURFACE ENERGY +! BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF DOWNWARD RADIATION +! AND PRECIP) +! ---------------------------------------------------------------------- +! SFLX_SEAICE ARGUMENT LIST KEY: +! ---------------------------------------------------------------------- +! C CONFIGURATION INFORMATION +! F FORCING DATA +! I OTHER (INPUT) FORCING DATA +! S SURFACE CHARACTERISTICS +! H HISTORY (STATE) VARIABLES +! O OUTPUT VARIABLES +! D DIAGNOSTIC OUTPUT +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- +! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND +! 1800 SECS OR LESS) +! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES +! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN +! PARAMETER NSOLD SET BELOW) +! ---------------------------------------------------------------------- +! 3. FORCING DATA (F): +! ---------------------------------------------------------------------- +! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) +! SOLNET NET DOWNWARD SOLAR RADIATION ((W M-2; POSITIVE) +! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) +! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) +! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! FFROZP FRACTION OF FROZEN PRECIPITATION +! ---------------------------------------------------------------------- +! 4. OTHER FORCING (INPUT) DATA (I): +! ---------------------------------------------------------------------- +! Q2SAT SAT SPECIFIC HUMIDITY AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP +! (KG KG-1 K-1) +! ---------------------------------------------------------------------- +! 5. CANOPY/SOIL CHARACTERISTICS (S): +! ---------------------------------------------------------------------- +! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM +! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) +! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR +! TEMPERATURE) +! Z0BRD Background fixed roughness length (M) +! Z0 Time varying roughness length (M) as function of snow depth +! +! EMISSI Surface emissivity (between 0 and 1) +! ---------------------------------------------------------------------- +! 6. HISTORY (STATE) VARIABLES (H): +! ---------------------------------------------------------------------- +! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) +! STC(NSOIL) SOIL TEMP (K) +! SNOWH ACTUAL SNOW DEPTH (M) +! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) +! NOTE: SNOW DENSITY = SNEQV/SNOWH +! ALBEDO SURFACE ALBEDO +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE +! IT HAS BEEN MULTIPLIED BY WIND SPEED. +! ---------------------------------------------------------------------- +! 7. OUTPUT (O): +! ---------------------------------------------------------------------- +! OUTPUT VARIABLES NECESSARY FOR A COUPLED NWP MODEL. FOR THIS APPLICATION, +! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT +! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM +! SURFACE) +! ETA_KINEMATIC actual latent heat flux in Kg m-2 s-1 +! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM +! SURFACE) +! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +! ---------------------------------------------------------------------- +! ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK (W m-2) +! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) +! ---------------------------------------------------------------------- +! ETP POTENTIAL EVAPORATION (W m-2) +! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) +! ---------------------------------------------------------------------- +! FLX1 PRECIP-SNOW SFC (W M-2) +! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) +! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) +! ---------------------------------------------------------------------- +! SNOMLT SNOW MELT (M) (WATER EQUIVALENT) +! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) +! ---------------------------------------------------------------------- +! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE +! ---------------------------------------------------------------------- +! 8. DIAGNOSTIC OUTPUT (D): +! ---------------------------------------------------------------------- +! Q1 Effective mixing ratio at surface (kg kg-1), used for +! diagnosing the mixing ratio at 2 meter for coupled model +! Documentation SNOABL2 ????? +! What categories of arguments do these variables fall into ???? +! Documentation for RIBB ????? +! What category of argument does RIBB fall into ????? +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- + integer, intent(in) :: iiloc, jjloc + INTEGER, INTENT(IN) :: SEAICE_ALBEDO_OPT + REAL, INTENT(IN) :: SEAICE_ALBEDO_DEFAULT + INTEGER, INTENT(IN) :: SEAICE_SNOWDEPTH_OPT + REAL, INTENT(IN) :: SEAICE_SNOWDEPTH_MAX + REAL, INTENT(IN) :: SEAICE_SNOWDEPTH_MIN + + LOGICAL :: FRZGRA, SNOWNG + + INTEGER,INTENT(IN) :: NSOIL + + REAL, INTENT(IN) :: DT,DQSDT2,LWDN,PRCP, & + Q2,Q2SAT,SFCPRS,SFCTMP,SNOALB,ALBEDOSI, & + SOLNET,TBOT,TH2,ZLVL, & + FFROZP + REAL, INTENT(OUT) :: ALBEDO + REAL, INTENT(INOUT):: CH, & + SNEQV,SNCOVR,SNOWH,T1,Z0BRD, & + EMISSI + REAL, INTENT(IN) :: SNOWONSI + REAL, INTENT(IN) :: SITHICK + REAL, INTENT(INOUT):: RIBB + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL,DIMENSION(1:NSOIL):: ZSOIL + + REAL,INTENT(OUT) :: ETA_KINEMATIC,DEW,ESNOW,ETA, & + ETP,FLX1,FLX2,FLX3,SHEAT,RUNOFF1, & + SSOIL, & + SNOMLT, & + FDOWN,Q1,Z0 + REAL :: DF1,DF1A, & + DSOIL,DTOT,FRCSNO,FRCSOI, & + RCH,RR, & + SNDENS,SNCOND,SN_NEW, & + T24,T2V,TH2V,TSNOW + + REAL :: RHO + INTEGER :: KZ, K + + REAL :: ALB_SNOW + REAL :: ALB_ICE + REAL :: Z0N + REAL :: SNCOVRR + +! ---------------------------------------------------------------------- +! DECLARATIONS - PARAMETERS +! ---------------------------------------------------------------------- + + REAL, PARAMETER :: LVH2O = 2.501E+6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + REAL, PARAMETER :: R = 287.04 + + iloc = iiloc + jloc = jjloc +! ---------------------------------------------------------------------- +! INITIALIZATION +! ---------------------------------------------------------------------- + + RUNOFF1 = 0.0 + SNOMLT = 0.0 + +! ---------------------------------------------------------------------- +! SEA-ICE LAYERS ARE EQUAL THICKNESS AND SUM TO METERS +! ---------------------------------------------------------------------- + + DO KZ = 1,NSOIL + ZSOIL (KZ) = -SITHICK * FLOAT (KZ) / FLOAT (NSOIL) + END DO + +! ---------------------------------------------------------------------- + + Z0BRD = 0.001 +! ALB = 0.82 ! Arctic pre-melt spring and post-melt autumn +! ALB = 0.80 ! Antarctica +! ALB = 0.50 ! Arctic mid-summer (ice and melt ponds) +! ALB = 0.65 ! Arctic bare ice with no snow and no melt ponds + +! ---------------------------------------------------------------------- +! INITIALIZE PRECIPITATION LOGICALS. +! ---------------------------------------------------------------------- + + SNOWNG = .FALSE. + FRZGRA = .FALSE. + +! ---------------------------------------------------------------------- +! OVER SEA-ICE, IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER +! BOUND (0.01 M FOR SEA-ICE, 0.10 M FOR GLACIAL-ICE), THEN SET AT LOWER +! BOUND +! ---------------------------------------------------------------------- +! FOR SEA-ICE CASE, ASSIGN DEFAULT WATER-EQUIV SNOW ON TOP +! ---------------------------------------------------------------------- + + SELECT CASE ( SEAICE_ALBEDO_OPT ) + + CASE DEFAULT + + IF ( SNEQV < 0.01 ) THEN + SNEQV = 0.01 + SNOWH = 0.05 + ENDIF + + CASE ( 1 ) ! Arctic sea-ice albedo from Mills (2011) + + IF ( SNEQV < 0.0001 ) THEN + SNEQV = 0.0001 + SNOWH = 0.0005 + ENDIF + + END SELECT + + + IF ( SEAICE_SNOWDEPTH_OPT == 0 ) THEN + + ! + ! Enforce bounds on snow depth, maintaining original snow density. + ! + + SNDENS = SNEQV / SNOWH + SNOWH = MAX ( SEAICE_SNOWDEPTH_MIN , MIN ( SNOWH , SEAICE_SNOWDEPTH_MAX ) ) + SNEQV = SNOWH * SNDENS + + ELSEIF ( SEAICE_SNOWDEPTH_OPT == 1 ) THEN + + ! + ! Regardless of the assignments above, we want to enforce + ! a specified snow depth and density on sea ice. + ! + + SNDENS = 0.3 + SNOWH = SNOWONSI + SNEQV = SNOWH * SNDENS + ENDIF + +! ---------------------------------------------------------------------- +! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND +! SNOW THERMAL CONDUCTIVITY "SNCOND" +! ---------------------------------------------------------------------- + + SNDENS = SNEQV / SNOWH + IF(SNDENS > 1.0) THEN + FATAL_ERROR( 'Physical snow depth is less than snow water equiv.' ) + ENDIF + CALL CSNOW (SNCOND,SNDENS) + +! ---------------------------------------------------------------------- +! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. +! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! +! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND +! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. +! ---------------------------------------------------------------------- + + IF (PRCP > 0.0) THEN +! snow defined when fraction of frozen precip (FFROZP) > 0.5, +! passed in from model microphysics. + IF (FFROZP .GT. 0.5) THEN + SNOWNG = .TRUE. + ELSE + IF (T1 <= TFREEZ) FRZGRA = .TRUE. + END IF + END IF + +! ---------------------------------------------------------------------- +! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP +! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD +! IT TO THE EXISTING SNOWPACK. +! ---------------------------------------------------------------------- + + IF ( SNOWNG .OR. FRZGRA ) THEN + SN_NEW = PRCP * DT * 0.001 + SNEQV = SNEQV + SN_NEW + +! ---------------------------------------------------------------------- +! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. +! UPDATE SNOW THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + + CALL SNOW_NEW ( SFCTMP , SN_NEW , SNOWH , SNDENS ) + ! + ! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3 + ! for "cold permanent ice" or new "dry" snow + ! + IF ( SNCOVR .GT. 0.99 ) THEN + ! + ! if soil temperature less than 268.15 K, treat as typical + ! Antarctic/Greenland snow firn + ! + IF ( STC(1) .LT. (TFREEZ - 5.) ) SNDENS = 0.2 + IF ( SNOWNG .AND. (T1.LT.273.) .AND. (SFCTMP.LT.273.) ) SNDENS=0.2 + ENDIF + + CALL CSNOW (SNCOND,SNDENS) + + END IF + +! ---------------------------------------------------------------------- +! ALBEDO OF SEA ICE +! ---------------------------------------------------------------------- + + + SELECT CASE ( SEAICE_ALBEDO_OPT ) + + CASE DEFAULT + + SNCOVR = 1.0 + EMISSI = 0.98 + ALBEDO = SEAICE_ALBEDO_DEFAULT +! ALBEDO = 0.82 ! Arctic pre-melt spring and post-melt autumn +! ALBEDO = 0.80 ! Antarctica +! ALBEDO = 0.50 ! Arctic mid-summer (ice and melt ponds) +! ALBEDO = 0.65 ! Arctic bare ice with no snow and no melt ponds + + CASE ( 1 ) ! Arctic sea-ice albedo from Mills (2011) + + ! + ! Make albedo of snow on sea-ice a function of skin temperature: + ! + IF (T1 < 268.15) THEN + alb_snow = 0.8 + ELSEIF ( ( T1 >= 268.15 ) .AND. ( T1 < 273.15 ) ) then + alb_snow = 0.65 - ( 0.03 * (T1 - 273.15) ) + ELSE + alb_snow = 0.65 + ENDIF + + ! + ! Make albedo of snow-free sea-ice a function of air temperature + ! + IF ( SFCTMP <= 273.15 ) THEN + alb_ice = 0.65 + ELSEIF ( ( SFCTMP > 273.15 ) .and. ( SFCTMP < 278.15 ) ) THEN + alb_ice = 0.65 - ( 0.04 * (SFCTMP - 273.15) ) + ELSE + alb_ice = 0.45 + ENDIF + + ! + ! Define a snow-cover fraction for use only with Mills sea-ice albedo + ! + Z0N = 0.10 ! Approximate roughness length of snow-covered surface + SNCOVRR = SNOWH / ( SNOWH + Z0N ) + + ! + ! Final albedo over sea-ice point is a combination of the snow + ! albedo and the snow-free ice albedo, weighted by the snow cover. + ! + ALBEDO = (SNCOVRR * alb_snow ) + ( ( 1.0 - SNCOVRR) * alb_ice ) + + CASE ( 2 ) ! Seaice albedo from 2d field + + SNCOVR = 1.0 + EMISSI = 0.98 + ALBEDO = ALBEDOSI + + END SELECT + +! ---------------------------------------------------------------------- +! THERMAL CONDUCTIVITY FOR SEA-ICE CASE +! ---------------------------------------------------------------------- + DF1 = 2.2 + + DSOIL = - (0.5 * ZSOIL (1)) + + DTOT = SNOWH + DSOIL + FRCSNO = SNOWH / DTOT + +! 1. HARMONIC MEAN (SERIES FLOW) +! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) + FRCSOI = DSOIL / DTOT +! 2. ARITHMETIC MEAN (PARALLEL FLOW) +! DF1 = FRCSNO*SNCOND + FRCSOI*DF1 + +! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) +! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) +! weigh DF by snow fraction + DF1A = FRCSNO * SNCOND + FRCSOI * DF1 + +! ---------------------------------------------------------------------- +! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY +! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP +! MID-LAYER SOIL TEMPERATURE +! ---------------------------------------------------------------------- + DF1 = DF1A * SNCOVR + DF1 * ( 1.0 - SNCOVR ) + + SSOIL = DF1 * ( T1 - STC(1) ) / DTOT + +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM +! THE PREVIOUS TIMESTEP. +! ---------------------------------------------------------------------- + + CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH) + +! ---------------------------------------------------------------------- +! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN +! PENMAN EP SUBROUTINE THAT FOLLOWS +! ---------------------------------------------------------------------- + FDOWN = SOLNET + LWDN +! ---------------------------------------------------------------------- +! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES +! PENMAN. +! ---------------------------------------------------------------------- + T2V = SFCTMP * (1.0+ 0.61 * Q2 ) + T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP + RHO = SFCPRS / ( RD * T2V ) + ! RCH = RHO * CP * CH + RCH = RHO * 1004.6 * CH ! CP is defined different in subroutine PENMAN. + ! Pulling this computation out of PENMAN changed + ! the results. So I'm hard-coding the PENMAN + ! value here, but perhaps this should go back + ! into PENMAN for now. + +! ---------------------------------------------------------------------- +! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND +! OTHER PARTIAL PRODUCTS AND SUMS FOR LATER CALCULATIONS. +! ---------------------------------------------------------------------- + + CALL PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & + Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & + DQSDT2,FLX2,EMISSI,T1) + + ESNOW = 0.0 + CALL SNOPAC (ETP,ETA,PRCP,SNOWNG, & + NSOIL,DT,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + SFCPRS,RCH,RR,SNCOVR,SNEQV,SNDENS, & + SNOWH,ZSOIL,TBOT, & + SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB, & + SEAICE_ALBEDO_OPT) +! ETA_KINEMATIC = ESNOW + ETA_KINEMATIC = ETP + + IF ( SEAICE_SNOWDEPTH_OPT == 0 ) THEN + + ! + ! Set bounds on snow depth, maintaining snow density. + ! + SNDENS = SNEQV / SNOWH + SNOWH = MAX ( SEAICE_SNOWDEPTH_MIN , MIN ( SNOWH , SEAICE_SNOWDEPTH_MAX ) ) + SNEQV = SNOWH * SNDENS + + ELSEIF ( SEAICE_SNOWDEPTH_OPT == 1 ) THEN + + ! + ! Regardless of the results of snopac, we want to enforce + ! a specified snow depth and density on sea ice. + ! + SNDENS = 0.3 + SNOWH = SNOWONSI + SNEQV = SNOWH * SNDENS + ENDIF + +! Calculate effective mixing ratio at ground level (skin) + Q1=Q2+ETA_KINEMATIC*CP/RCH +! +! ---------------------------------------------------------------------- +! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + + SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + +! ---------------------------------------------------------------------- +! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + + ESNOW = ESNOW * LSUBS + ETP = ETP*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) + IF (ETP .GT. 0.) THEN + ETA = ESNOW + ELSE + ETA = ETP + ENDIF + +! ---------------------------------------------------------------------- +! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: +! SSOIL>0: WARM THE SURFACE (NIGHT TIME) +! SSOIL<0: COOL THE SURFACE (DAY TIME) +! ---------------------------------------------------------------------- + + SSOIL = -1.0* SSOIL + +! ---------------------------------------------------------------------- +! FOR THE CASE OF SEA-ICE, ADD ANY +! SNOWMELT DIRECTLY TO SURFACE RUNOFF (RUNOFF1) SINCE THERE IS NO +! SOIL MEDIUM, AND THUS NO CALL TO SUBROUTINE SMFLX (FOR SOIL MOISTURE +! TENDENCY). +! ---------------------------------------------------------------------- + RUNOFF1 = SNOMLT/DT + +! ---------------------------------------------------------------------- + END SUBROUTINE SFLX_SEAICE +! ---------------------------------------------------------------------- + + SUBROUTINE CSNOW (SNCOND,DSNOW) + +! ---------------------------------------------------------------------- +! SUBROUTINE CSNOW +! FUNCTION CSNOW +! ---------------------------------------------------------------------- +! CALCULATE SNOW TERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: DSNOW + REAL, INTENT(OUT):: SNCOND + REAL :: C + REAL, PARAMETER :: UNIT = 0.11631 + +! ---------------------------------------------------------------------- +! SNCOND IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 +! ---------------------------------------------------------------------- + C = 0.328*10** (2.25* DSNOW) +! CSNOW=UNIT*C + +! ---------------------------------------------------------------------- +! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 +! ---------------------------------------------------------------------- +! SNCOND=0.0293*(1.+100.*DSNOW**2) +! CSNOW=0.0293*(1.+100.*DSNOW**2) + +! ---------------------------------------------------------------------- +! E. ANDERSEN FROM FLERCHINGER +! ---------------------------------------------------------------------- +! SNCOND=0.021+2.51*DSNOW**2 +! CSNOW=0.021+2.51*DSNOW**2 + +! SNCOND = UNIT * C +! double snow thermal conductivity + SNCOND = 2.0 * UNIT * C + +! ---------------------------------------------------------------------- + END SUBROUTINE CSNOW +! ---------------------------------------------------------------------- + SUBROUTINE HRTICE (RHSTS,STC,TBOT,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE (ICE=1) OR GLACIAL +! ICE (ICE=-1). COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE +! TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! +! (NOTE: THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT +! NOT FOR NON-GLACIAL LAND (ICE = 0). +! ---------------------------------------------------------------------- + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + + REAL, INTENT(IN) :: DF1,YY,ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: AI, BI,CI + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STC, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: RHSTS + REAL, INTENT(IN) :: TBOT + REAL :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL, & + ZBOT + REAL :: HCPCT + REAL :: DF1K + REAL :: DF1N + REAL :: ZMD + +! ---------------------------------------------------------------------- +! SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY, +! HCPCT = 1880.0*917.0. +! ---------------------------------------------------------------------- + ! Sea-ice values + HCPCT = 1.72396E+6 + +! ---------------------------------------------------------------------- +! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE +! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2. +! ---------------------------------------------------------------------- +! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE +! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE +! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK +! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + ZBOT = ZSOIL (NSOIL) + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. +! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC +! RHSTS FOR THE TOP SOIL LAYER. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1/ (0.5 * ZSOIL (1) * ZSOIL (1) * HCPCT * & + ZZ1) + DTSDZ = ( STC (1) - STC (2) ) / ( -0.5 * ZSOIL (2) ) + SSOIL = DF1 * ( STC (1) - YY ) / ( 0.5 * ZSOIL (1) * ZZ1 ) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + RHSTS (1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL (1) * HCPCT ) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DF1K = DF1 + DF1N = DF1 + DO K = 2,NSOIL + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. +! ---------------------------------------------------------------------- + IF (K /= NSOIL) THEN + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K))*HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. +! ---------------------------------------------------------------------- + ELSE + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC (K) - TBOT)/ (.5 * (ZSOIL (K -1) + ZSOIL (K)) & + - ZBOT) + CI (K) = 0. + END IF +! ---------------------------------------------------------------------- +! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM + AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + BI (K) = - (AI (K) + CI (K)) +! ---------------------------------------------------------------------- +! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. +! ---------------------------------------------------------------------- + DF1K = DF1N + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRTICE +! ---------------------------------------------------------------------- + + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI,T1) + +! ---------------------------------------------------------------------- +! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS +! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE +! CALLING ROUTINE FOR LATER USE. +! ---------------------------------------------------------------------- + + IMPLICIT NONE + LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA + REAL, INTENT(IN) :: CH, DQSDT2, FDOWN, PRCP, & + & Q2, Q2SAT, SSOIL, SFCPRS, SFCTMP, & + & TH2,EMISSI + REAL, INTENT(IN) :: T1, T24, RCH + REAL, INTENT(OUT) :: ETP,FLX2,RR + REAL :: ELCP1, LVS, EPSCA, A, DELTA, FNET, RAD + + REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6,CP = 1004.6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + +! ---------------------------------------------------------------------- +! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. +! ---------------------------------------------------------------------- + + IF ( T1 > 273.15 ) THEN + ELCP1=ELCP + LVS=LSUBC + ELSE + ELCP1 = ELCP*LSUBS/LSUBC + LVS = LSUBS + ENDIF + + FLX2 = 0.0 + DELTA = ELCP1 * DQSDT2 + RR = EMISSI * T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + +! ---------------------------------------------------------------------- +! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT +! EFFECTS CAUSED BY FALLING PRECIPITATION. +! ---------------------------------------------------------------------- + + IF ( PRCP > 0.0 ) THEN + IF (.NOT. SNOWNG) THEN + RR = RR + CPH2O * PRCP / RCH + ELSE + RR = RR + CPICE * PRCP / RCH + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! INCLUDE THE LATENT HEAT EFFECTS OF FREEZING RAIN CONVERTING TO ICE ON +! IMPACT IN THE CALCULATION OF FLX2 AND FNET. +! ---------------------------------------------------------------------- + + FNET = FDOWN - EMISSI * SIGMA * T24 - SSOIL + IF (FRZGRA) THEN + FLX2 = - LSUBF * PRCP + FNET = FNET - FLX2 + END IF + +! ---------------------------------------------------------------------- +! FINISH PENMAN EQUATION CALCULATIONS. +! ---------------------------------------------------------------------- + + RAD = FNET / RCH + TH2 - SFCTMP + A = ELCP1 * (Q2SAT - Q2) + EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) + ETP = EPSCA * RCH / LVS + +! ---------------------------------------------------------------------- + END SUBROUTINE PENMAN +! ---------------------------------------------------------------------- + + SUBROUTINE SHFLX (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DF1,DT,TBOT,YY, ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + INTEGER :: I + REAL, PARAMETER :: T0 = 273.15 + +! ---------------------------------------------------------------------- +! HRTICE ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + CALL HRTICE (RHSTS,STC,TBOT,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + DO I = 1,NSOIL + STC (I) = STCF (I) + END DO + +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SNOPAC (ETP,ETA,PRCP,SNOWNG, & + NSOIL,DT,DF1, & + Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + SFCPRS,RCH,RR,SNCOVR,ESD,SNDENS, & + SNOWH,ZSOIL,TBOT, & + SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI, & + RIBB, SEAICE_ALBEDO_OPT) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(IN) :: DF1, & + & DT,FDOWN, & + & PRCP,Q2, & + & RCH,RR,SFCPRS, SFCTMP, & + & T24, & + & TBOT,TH2,EMISSI + REAL, INTENT(INOUT) :: ESD,FLX2,SNOWH,SNCOVR, & + & SNDENS, T1, RIBB, ETP + REAL, INTENT(OUT) :: DEW,ESNOW, & + & FLX1,FLX3, SSOIL,SNOMLT + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL :: DENOM,DSOIL,DTOT,ETA, & + & ESNOW1, ESNOW2, ETA1,ETP1,ETP2, & + & ETANRG, EX, SEH, & + & SNCOND,T12, T12A, & + & T12B, T14, YY, ZZ1 + INTEGER, INTENT(IN) :: SEAICE_ALBEDO_OPT + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + LSUBS = 2.83E+6, SNOEXP = 2.0 + +! ---------------------------------------------------------------------- +! SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE POTENTIAL RATE. +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + DEW = 0. + ESNOW = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! ---------------------------------------------------------------------- +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + IF (ETP <= 0.0) THEN + IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN + ETP=(MIN(ETP*(1.0-RIBB),0.)*SNCOVR/0.980 + ETP*(0.980-SNCOVR))/0.980 + ENDIF + ETP1 = ETP * 0.001 + DEW = -ETP1 + ESNOW2 = ETP1*DT + ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS) + ELSE + ETP1 = ETP * 0.001 + ESNOW = ETP + ESNOW1 = ESNOW*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW*LSUBS + ESNOW = ETP*SNCOVR + ESNOW1 = ESNOW*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW*LSUBS + END IF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1 = 0.0 + IF (SNOWNG) THEN + FLX1 = CPICE * PRCP * (T1- SFCTMP) + ELSE + IF (PRCP > 0.0) FLX1 = CPH2O * PRCP * (T1- SFCTMP) +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + END IF + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL + DENOM = 1.0+ DF1 / (DTOT * RR * RCH) +! surface emissivity weighted by snow cover fraction +! T12A = ( (FDOWN - FLX1 - FLX2 - & +! & ((SNCOVR*EMISSI_S)+EMISSI*(1.0-SNCOVR))*SIGMA *T24)/RCH & +! & + TH2 - SFCTMP - ETANRG/RCH ) / RR + T12A = ( (FDOWN - FLX1 - FLX2 - EMISSI * SIGMA * T24)/ RCH & + + TH2 - SFCTMP - ETANRG / RCH ) / RR + + T12B = DF1 * STC (1) / (DTOT * RR * RCH) + +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- + T12 = (SFCTMP + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN + T1 = T12 + SSOIL = DF1 * (T1- STC (1)) / DTOT +! ESD = MAX (0.0, ESD- ETP2) + ESD = MAX(0.0, ESD-ESNOW2) + FLX3 = 0.0 + EX = 0.0 + + SNOMLT = 0.0 +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- + ELSE + T1 = TFREEZ + SSOIL = DF1 * (T1- STC (1)) / DTOT + +! ---------------------------------------------------------------------- +! IF POTENTIAL EVAP (SUBLIMATION) GREATER THAN DEPTH OF SNOWPACK. +! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. +! ---------------------------------------------------------------------- + + IF (ESD-ESNOW2 <= ESDMIN) THEN + ESD = 0.0 + EX = 0.0 + SNOMLT = 0.0 + FLX3 = 0.0 +! ---------------------------------------------------------------------- +! SUBLIMATION LESS THAN DEPTH OF SNOWPACK +! SNOWPACK (ESD) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) +! ---------------------------------------------------------------------- + ELSE + ESD = ESD-ESNOW2 + SEH = RCH * (T1- TH2) + T14 = ( T1 * T1 ) * ( T1 * T1 ) + FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG + IF (FLX3 <= 0.0) FLX3 = 0.0 +! ---------------------------------------------------------------------- +! SNOWMELT REDUCTION DEPENDING ON SNOW COVER +! ---------------------------------------------------------------------- + EX = FLX3*0.001/ LSUBF + +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + SNOMLT = EX * DT + IF (ESD- SNOMLT >= ESDMIN) THEN + ESD = ESD- SNOMLT + ELSE + ! + ! SNOWMELT EXCEEDS SNOW DEPTH + ! + EX = ESD / DT + FLX3 = EX *1000.0* LSUBF + SNOMLT = ESD + + ESD = 0.0 + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! END OF 'T12 .LE. TFREEZ' IF-BLOCK +! ---------------------------------------------------------------------- + + ENDIF + +! ---------------------------------------------------------------------- +! FOR SEA-ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE +! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO +! SUBROUTINE SNOPAC) +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW +! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR IN SMFLX (BELOW). +! IF SEAICE (ICE==1) SKIP CALL TO SMFLX, SINCE NO SOIL MEDIUM FOR SEA-ICE +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTED FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. +! ---------------------------------------------------------------------- + + ZZ1 = 1.0 + YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 + +! ---------------------------------------------------------------------- +! SHFLX WILL CALC/UPDATE THE ICE TEMPS. +! ---------------------------------------------------------------------- + + CALL SHFLX (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) + +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + SELECT CASE ( SEAICE_ALBEDO_OPT ) + + CASE DEFAULT + + IF (ESD .GE. 0.01) THEN + CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) + ELSE + ESD = 0.01 + SNOWH = 0.05 +!KWM???? SNDENS = +!KWM???? SNCOND = + SNCOVR = 1.0 + ENDIF + + CASE ( 1 ) ! Arctic sea-ice albedo from Mills (2011) + + IF ( ESD >= 0.0001 ) THEN + CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) + ELSE + ESD = 0.0001 + SNOWH = 0.0005 + SNCOVR = 0.005 + ENDIF + + END SELECT +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- +! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW +! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S +! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR +! KOREN, 03/25/95. +! ---------------------------------------------------------------------- +! ESD WATER EQUIVALENT OF SNOW (M) +! DTSEC TIME STEP (SEC) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! TSNOW SNOW SURFACE TEMPERATURE (K) +! TSOIL SOIL SURFACE TEMPERATURE (K) + +! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER :: IPOL, J + REAL, INTENT(IN) :: ESD, DTSEC,TSNOW,TSOIL + REAL, INTENT(INOUT) :: SNOWH, SNDENS + REAL :: BFAC,DSX,DTHR,DW,SNOWHC,PEXP, & + TAVGC,TSNOWC,TSOILC,ESDC,ESDCX + REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, & + KN = 4000.0 +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + ESDC = ESD *100. + DTHR = DTSEC /3600. + TSNOWC = TSNOW -273.15 + TSOILC = TSOIL -273.15 + +! ---------------------------------------------------------------------- +! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION +! SNDENS=DS0*(EXP(BFAC*ESD)-1.)/(BFAC*ESD) +! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) +! NOTE: BFAC*ESD IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED +! NUMERICALLY BELOW: +! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) +! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G +! ---------------------------------------------------------------------- + TAVGC = 0.5* (TSNOWC + TSOILC) + IF (ESDC > 1.E-2) THEN + ESDCX = ESDC + ELSE + ESDCX = 1.E-2 + END IF + +! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) +! ---------------------------------------------------------------------- +! THE FUNCTION OF THE FORM (e**x-1)/x EMBEDDED IN ABOVE EXPRESSION +! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" +! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT +! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS +! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x +! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED +! POLYNOMIAL EXPANSION. + +! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, +! IS GOVERNED BY ITERATION LIMIT "IPOL". +! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE +! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). +! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) +! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) +! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... +! ---------------------------------------------------------------------- + BFAC = DTHR * C1* EXP (0.08* TAVGC - C2* SNDENS) + IPOL = 4 + PEXP = 0. +! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) + DO J = IPOL,1, -1 + PEXP = (1. + PEXP)* BFAC * ESDCX / REAL (J +1) + END DO + + PEXP = PEXP + 1. +! ---------------------------------------------------------------------- +! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION +! ---------------------------------------------------------------------- +! END OF KOREAN FORMULATION + +! BASE FORMULATION (COGLEY ET AL., 1990) +! CONVERT DENSITY FROM G/CM3 TO KG/M3 +! DSM=SNDENS*1000.0 + +! DSX=DSM+DTSEC*0.5*DSM*G*ESD/ +! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) + +! & CONVERT DENSITY FROM KG/M3 TO G/CM3 +! DSX=DSX/1000.0 + +! END OF COGLEY ET AL. FORMULATION + +! ---------------------------------------------------------------------- +! SET UPPER/LOWER LIMIT ON SNOW DENSITY +! ---------------------------------------------------------------------- + DSX = SNDENS * (PEXP) + IF (DSX > 0.40) DSX = 0.40 + IF (DSX < 0.05) DSX = 0.05 +! ---------------------------------------------------------------------- +! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING +! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER +! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. +! ---------------------------------------------------------------------- + SNDENS = DSX + IF (TSNOWC >= 0.) THEN + DW = 0.13* DTHR /24. + SNDENS = SNDENS * (1. - DW) + DW + IF (SNDENS >= 0.40) SNDENS = 0.40 +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. +! CHANGE SNOW DEPTH UNITS TO METERS +! ---------------------------------------------------------------------- + END IF + SNOWHC = ESDC / SNDENS + SNOWH = SNOWHC *0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- +! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW +! SNCOVR FRACTIONAL SNOW COVER +! Z0 ROUGHNESS LENGTH (m) +! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: SNCOVR, Z0BRD + REAL, INTENT(OUT) :: Z0 + REAL, PARAMETER :: Z0S=0.001 + REAL, INTENT(IN) :: SNOWH + REAL :: BURIAL + REAL :: Z0EFF + +!m Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S + BURIAL = 7.0*Z0BRD - SNOWH + IF(BURIAL.LE.0.0007) THEN + Z0EFF = Z0S + ELSE + Z0EFF = BURIAL/7.0 + ENDIF + + Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- + + + SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH AND DENSITY TO ACCOUNT FOR THE NEW SNOWFALL. +! NEW VALUES OF SNOW DEPTH & DENSITY RETURNED. + +! TEMP AIR TEMPERATURE (K) +! NEWSN NEW SNOWFALL (M) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: NEWSN, TEMP + REAL, INTENT(INOUT) :: SNDENS, SNOWH + REAL :: DSNEW, HNEWC, SNOWHC,NEWSNC,TEMPC + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + NEWSNC = NEWSN *100. + +! ---------------------------------------------------------------------- +! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE +! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED +! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, +! VEMADOLEN, SWEDEN, 1980, 172-177PP. +!----------------------------------------------------------------------- + TEMPC = TEMP -273.15 + IF (TEMPC <= -15.) THEN + DSNEW = 0.05 + ELSE + DSNEW = 0.05+0.0017* (TEMPC +15.)**1.5 + END IF +! ---------------------------------------------------------------------- +! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL +! ---------------------------------------------------------------------- + HNEWC = NEWSNC / DSNEW + IF (SNOWHC + HNEWC .LT. 1.0E-3) THEN + SNDENS = MAX(DSNEW,SNDENS) + ELSE + SNDENS = (SNOWHC * SNDENS + HNEWC * DSNEW)/ (SNOWHC + HNEWC) + ENDIF + SNOWHC = SNOWHC + HNEWC + SNOWH = SNOWHC *0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- + +END MODULE module_sf_noah_seaice diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F new file mode 100644 index 0000000000..68313b682e --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noah_seaice_drv.F @@ -0,0 +1,519 @@ +!================================================================================================================= +module module_sf_noah_seaice_drv + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) +#else +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) +#endif + use module_sf_noah_seaice + implicit none +contains + subroutine seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNESS_OPT, & + & SEAICE_THICKNESS_DEFAULT, SEAICE_SNOWDEPTH_OPT, & + & SEAICE_SNOWDEPTH_MAX, SEAICE_SNOWDEPTH_MIN, & + & T3D, QV3D, P8W3D, DZ8W, NUM_SOIL_LAYERS, DT, FRPCPN, SR, & + & GLW, SWDOWN, RAINBL, SNOALB2D, QGH, XICE, XICE_THRESHOLD, & + & ALBSI, ICEDEPTH, SNOWSI, & + & TSLB, EMISS, ALBEDO, Z02D, TSK, SNOW, SNOWC, SNOWH2D, & + & CHS, CHS2, CQS2, & + & RIB, ZNT, LH, HFX, QFX, POTEVP, GRDFLX, QSFC, ACSNOW, & + & ACSNOM, SNOPCX, SFCRUNOFF, NOAHRES, & + & SF_URBAN_PHYSICS, B_T_BEP, B_Q_BEP, RHO, & + & IDS, IDE, JDS, JDE, KDS, KDE, & + & IMS, IME, JMS, JME, KMS, KME, & + & ITS, ITE, JTS, JTE, KTS, KTE ) +#if defined(wrfmodel) +#if (NMM_CORE != 1) + USE module_state_description, ONLY : NOAHUCMSCHEME + USE module_state_description, ONLY : BEPSCHEME + USE module_state_description, ONLY : BEP_BEMSCHEME +#endif +#endif + implicit none + + INTEGER, INTENT(IN) :: SEAICE_ALBEDO_OPT + REAL , INTENT(IN) :: SEAICE_ALBEDO_DEFAULT + INTEGER, INTENT(IN) :: SEAICE_THICKNESS_OPT + REAL, INTENT(IN) :: SEAICE_THICKNESS_DEFAULT + INTEGER, INTENT(IN) :: SEAICE_SNOWDEPTH_OPT + REAL, INTENT(IN) :: SEAICE_SNOWDEPTH_MAX + REAL, INTENT(IN) :: SEAICE_SNOWDEPTH_MIN + + INTEGER, INTENT(IN) :: IDS, & + & IDE, & + & JDS, & + & JDE, & + & KDS, & + & KDE + + INTEGER, INTENT(IN) :: IMS, & + & IME, & + & JMS, & + & JME, & + & KMS, & + & KME + + INTEGER, INTENT(IN) :: ITS, & + & ITE, & + & JTS, & + & JTE, & + & KTS, & + & KTE + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + & INTENT (IN) :: T3D, & + & QV3D, & + & P8W3D, & + & DZ8W + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT (IN) :: SR, & + & GLW, & + & QGH, & + & SWDOWN, & + & RAINBL, & + & SNOALB2D, & + & XICE, & + & RIB, & + & CHS + + LOGICAL, INTENT (IN) :: FRPCPN + REAL , INTENT (IN) :: DT + INTEGER, INTENT (IN) :: NUM_SOIL_LAYERS + REAL , INTENT (IN) :: XICE_THRESHOLD + + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & + INTENT(INOUT) :: TSLB + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT (INOUT) :: EMISS, & + & ALBEDO, & + & ALBSI, & + & Z02D, & + & SNOW, & + & TSK, & + & SNOWC, & + & SNOWH2D, & +! & CHS, & + & CQS2, & + ACSNOW, & + ACSNOM, & + SFCRUNOFF + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(INOUT) :: POTEVP, & + SNOPCX + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT (OUT) :: HFX, & + & LH, & + & QFX, & + & ZNT, & + & GRDFLX, & + & QSFC, & + & CHS2 + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT (OUT) :: NOAHRES + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT(INOUT) :: SNOWSI + + REAL, DIMENSION( ims:ime, jms:jme ) , & + & INTENT (INOUT) :: ICEDEPTH + + INTEGER, INTENT (IN) :: SF_URBAN_PHYSICS + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + & INTENT (INOUT) :: B_Q_BEP, & + & B_T_BEP + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + & INTENT (IN) :: RHO + + INTEGER :: I + INTEGER :: J + REAL :: FFROZP + REAL :: ZLVL + INTEGER :: NSOIL + REAL :: LWDN + REAL :: SOLNET + REAL :: SFCPRS + REAL :: PRCP + REAL :: SFCTMP + REAL :: Q2 + REAL :: TH2 + REAL :: Q2SAT + REAL :: DQSDT2 + REAL :: SNOALB + REAL :: TBOT + REAL :: SITHICK + + REAL :: ALBEDOK + REAL :: ALBBRD + REAL :: Z0BRD + REAL :: EMISSI + REAL :: T1 + REAL, DIMENSION(1:NUM_SOIL_LAYERS):: STC + REAL :: SNOWH + REAL :: SNEQV + REAL :: CH + REAL :: SNCOVR + REAL :: RIBB + + REAL :: Z0 + REAL :: ETA + REAL :: SHEAT + REAL :: ETA_KINEMATIC + REAL :: FDOWN + REAL :: ESNOW + REAL :: DEW + REAL :: ETP + REAL :: SSOIL + REAL :: FLX1 + REAL :: FLX2 + REAL :: FLX3 + REAL :: SNOMLT + REAL :: RUNOFF1 + REAL :: Q1 + + REAL :: APES + REAL :: APELM + REAL :: PSFC + REAL :: SFCTSNO + REAL :: E2SAT + REAL :: Q2SATI + INTEGER :: NS + REAL :: FDTW + REAL :: FDTLIW + REAL :: ALBEDOSI + REAL :: SNOWONSI + REAL, PARAMETER :: CAPA = R_D / CP + REAL, PARAMETER :: A2 = 17.67 + REAL, PARAMETER :: A3 = 273.15 + REAL, PARAMETER :: A4 = 29.65 + REAL, PARAMETER :: A23M4 = A2 * ( A3 - A4 ) + REAL, PARAMETER :: ROW = 1.E3 + REAL, PARAMETER :: ELIW = XLF + REAL, PARAMETER :: ROWLIW = ROW * ELIW + + CHARACTER(len=80) :: message + + FDTLIW = DT / ROWLIW + FDTW = DT / ( XLV * RHOWATER ) + + NSOIL = NUM_SOIL_LAYERS + + SEAICE_JLOOP : do J = JTS, JTE + SEAICE_ILOOP : do I = ITS, ITE + + ! Skip the points that are not sea-ice points. + IF ( XICE(I,J) < XICE_THRESHOLD ) THEN + IF ( SEAICE_THICKNESS_OPT == 1 ) THEN + ICEDEPTH(I,J) = 0.0 + ENDIF + IF ( SEAICE_SNOWDEPTH_OPT == 1 ) THEN + SNOWSI(I,J) = 0.0 + ENDIF + CYCLE SEAICE_ILOOP + ENDIF + + SELECT CASE ( SEAICE_THICKNESS_OPT ) + CASE DEFAULT + WRITE(message,'("Namelist value for SEAICE_THICKNESS_OPT not recognized: ",I6)') SEAICE_THICKNESS_OPT + FATAL_ERROR(message) + CASE (0) + ! Use uniform sea-ice thickness. + SITHICK = SEAICE_THICKNESS_DEFAULT + CASE (1) + ! Use the sea-ice as read in from the input files. + ! Limit the to between 0.10 and 10.0 m. + IF ( ICEDEPTH(I,J) < -1.E6 ) THEN + WRITE_MESSAGE("Field ICEDEPTH not found in input files.") + WRITE_MESSAGE(".... Namelist SEAICE_THICKNESS_OPT=1 requires ICEDEPTH field.") + WRITE_MESSAGE(".... Try namelist option SEAICE_THICKNESS_OPT=0.") + FATAL_ERROR("SEAICE_THICKNESS_OPT") + ENDIF + SITHICK = MIN ( MAX ( 0.10 , ICEDEPTH(I,J) ) , 10.0 ) + ICEDEPTH(I,J) = SITHICK + END SELECT + + SFCTMP = T3D(I,1,J) + T1 = TSK(I,J) + IF ( SEAICE_ALBEDO_OPT == 2 ) THEN + IF ( ALBSI(I,J) < -1.E6 ) THEN + FATAL_ERROR("Field ALBSI not found in input. Field ALBSI is required if SEAICE_ALBEDO_OPT=2") + ENDIF + SNOALB = ALBSI(I,J) + ALBEDO(I,J) = ALBSI(I,J) + ALBEDOK = ALBSI(I,J) + ALBBRD = ALBSI(I,J) + ALBEDOSI = ALBSI(I,J) + ELSE + SNOALB = SNOALB2D(I,J) + ENDIF + ZLVL = 0.5 * DZ8W(I,1,J) + EMISSI = EMISS(I,J) ! But EMISSI might change in SFLX_SEAICE + LWDN = GLW(I,J) * EMISSI ! But EMISSI might change in SFLX_SEAICE + + ! convert snow water equivalent from mm to meter + SNEQV = SNOW(I,J) * 0.001 + + ! snow depth in meters + SNOWH = SNOWH2D(I,J) + SNCOVR = SNOWC(I,J) + + ! Use mid-day albedo to determine net downward solar (no solar zenith angle correction) + SOLNET = SWDOWN(I,J) * (1.-ALBEDO(I,J)) ! But ALBEDO might change after SFLX_SEAICE + + ! Pressure in middle of lowest layer. Why don't we use the true surface pressure? + ! Are there places where we would need to use the true surface pressure? + SFCPRS = ( P8W3D(I,KTS+1,j) + P8W3D(I,KTS,J) ) * 0.5 + + ! surface pressure + PSFC = P8W3D(I,1,J) + + ! Convert lowest model level humidity from mixing ratio to specific humidity + Q2 = QV3D(I,1,J) / ( 1.0 + QV3D(I,1,J) ) + + ! Calculate TH2 via Exner function + APES = ( 1.E5 / PSFC ) ** CAPA + APELM = ( 1.E5 / SFCPRS ) ** CAPA + TH2 = ( SFCTMP * APELM ) / APES + + ! Q2SAT is specific humidity + Q2SAT = QGH(I,J) / ( 1.0 + QGH(I,J) ) + DQSDT2 = Q2SAT * A23M4 / ( SFCTMP - A4 ) ** 2 + + SELECT CASE ( SEAICE_SNOWDEPTH_OPT ) + CASE DEFAULT + + WRITE(message,'("Namelist value for SEAICE_SNOWDEPTH_OPT not recognized: ",I6)') SEAICE_SNOWDEPTH_OPT + FATAL_ERROR(message) + + CASE ( 0 ) + + ! Minimum and maximum bounds on snow depth are enforced in SFLX_SEAICE + + CASE ( 1 ) + + ! Snow depth on sea ice comes from a 2D array, SNOWSI, bounded by user-specified + ! minimum and maximum values. No matter what anybody else says about snow + ! accumulation and melt, we want the snow depth on sea ice to be specified + ! as SNOWSI (bounded by SEAICE_SNOWDEPTH_MIN and SEAICE_SNOWDEPTH_MAX). + SNOWONSI = MAX ( SEAICE_SNOWDEPTH_MIN , MIN ( SNOWSI(I,J) , SEAICE_SNOWDEPTH_MAX ) ) + SNEQV = SNOWONSI * 0.3 + SNOWH2D(I,J) = SNOWONSI + + END SELECT + + IF ( SNOW(I,J) .GT. 0.0 ) THEN + ! If snow on surface, use ice saturation properties + SFCTSNO = SFCTMP ! Lowest model Air temperature + E2SAT = 611.2 * EXP ( 6174. * ( 1./273.15 - 1./SFCTSNO ) ) + Q2SATI = 0.622 * E2SAT / ( SFCPRS - E2SAT ) + Q2SATI = Q2SATI / ( 1.0 + Q2SATI ) ! Convert to specific humidity + ! T1 is skin temperature + IF (T1 .GT. 273.14) THEN + ! Warm ground temps, weight the saturation between ice and water according to SNOWC + Q2SAT = Q2SAT * (1.-SNOWC(I,J)) + Q2SATI * SNOWC(I,J) + DQSDT2 = DQSDT2 * (1.-SNOWC(I,J)) + Q2SATI * 6174. / (SFCTSNO**2) * SNOWC(I,J) + ELSE + ! Cold ground temps, use ice saturation only + Q2SAT = Q2SATI + DQSDT2 = Q2SATI * 6174. / (SFCTSNO**2) + ENDIF + IF ( ( T1 .GT. 273. ) .AND. ( SNOWC(I,J) .GT. 0.0 ) ) THEN + ! If (SNOW > 0) can we have (SNOWC <= 0) ? Perhaps not, so the check on + ! SNOWC here might be superfluous. + DQSDT2 = DQSDT2 * ( 1. - SNOWC(I,J) ) + ENDIF + ENDIF + + PRCP = RAINBL(I,J) / DT + + ! If "SR" is present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1) + ! SR from e.g. Ferrier microphysics + ! otherwise define from 1st atmos level temperature + + IF (FRPCPN) THEN + FFROZP = SR(I,J) + ELSE + IF (SFCTMP <= 273.15) THEN + FFROZP = 1.0 + ELSE + FFROZP = 0.0 + ENDIF + ENDIF + + ! Sea-ice point has deep-level temperature of about -1.8 C + TBOT = 271.36 + ! TBOT=273.15 ! appropriate value for lake ice. + + ! INTENT(IN) for SFLX_SEAICE, values unchanged by SFLX_SEAICE + ! I -- + ! J -- + ! FFROZP -- + ! DT -- + ! ZLVL -- + ! NSOIL -- + ! LWDN -- + ! SOLNET -- + ! SFCPRS -- + ! PRCP -- + ! SFCTMP -- + ! Q2 -- + ! TH2 -- + ! Q2SAT -- + ! DQSDT2 -- + ! SNOALB -- + ! TBOT -- + + Z0BRD = Z02D(I,J) + + DO NS = 1, NSOIL + STC(NS) = TSLB(I,NS,J) + ENDDO + + CH = CHS(I,J) + RIBB = RIB(I,J) + + ! INTENT(INOUT) for SFLX_SEAICE, values updated by SFLX_SEAICE + ! Z0BRD -- + ! EMISSI -- + ! T1 -- + ! STC -- + ! SNOWH -- + ! SNEQV -- + ! SNCOVR -- + ! CH -- but the result isn't used for anything. + ! Might as well be intent in to SFLX_SEAICE and changed locally in + ! that routine? + ! RIBB -- but the result isn't used for anything. + ! Might as well be intent in to SFLX_SEAICE and changed locally in + ! that routine? + + ! INTENT(OUT) for SFLX_SEAICE. Input value should not matter. + Z0 = -1.E36 + ETA = -1.E36 + SHEAT = -1.E36 + ETA_KINEMATIC = -1.E36 + FDOWN = -1.E36 ! Returned value unused. Might as well be local to SFLX_SEAICE ? + ESNOW = -1.E36 ! Returned value unused. Might as well be local to SFLX_SEAICE ? + DEW = -1.E36 ! Returned value unused. Might as well be local to SFLX_SEAICE ? + ETP = -1.E36 + SSOIL = -1.E36 + FLX1 = -1.E36 + FLX2 = -1.E36 + FLX3 = -1.E36 + SNOMLT = -1.E36 + RUNOFF1 = -1.E36 + Q1 = -1.E36 + + call sflx_seaice(I, J, SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, & !C + & SEAICE_SNOWDEPTH_OPT, SEAICE_SNOWDEPTH_MAX, & !C + & SEAICE_SNOWDEPTH_MIN, & !C + & FFROZP, DT, ZLVL, NSOIL, & !C + & SITHICK, & + & LWDN, SOLNET, SFCPRS, PRCP, SFCTMP, Q2, & !F + & TH2, Q2SAT, DQSDT2, & !I + & SNOALB, TBOT, Z0BRD, Z0, EMISSI, & !S + & T1, STC, SNOWH, SNEQV, ALBEDOK, CH, & !H + & ALBEDOSI, SNOWONSI, & + & ETA, SHEAT, ETA_KINEMATIC, FDOWN, & !O + & ESNOW, DEW, ETP, SSOIL, FLX1, FLX2, FLX3, & !O + & SNOMLT, SNCOVR, & !O + & RUNOFF1, Q1, RIBB) + + ! Update our 2d arrays with results from SFLX_SEAICE + ALBEDO(I,J) = ALBEDOK + EMISS(I,J) = EMISSI + TSK(I,J) = T1 + Z02D(I,J) = Z0BRD + SNOWH2D(I,J) = SNOWH + SNOWC(I,J) = SNCOVR + + ! Convert snow water equivalent from (m) back to (mm) + SNOW(I,J) = SNEQV * 1000. + + ! Update our ice temperature array with results from SFLX_SEAICE + DO NS = 1,NSOIL + TSLB(I,NS,J) = STC(NS) + ENDDO + + ! Intent (OUT) from SFLX_SEAICE + ZNT(I,J) = Z0 + LH(I,J) = ETA + HFX(I,J) = SHEAT + QFX(I,J) = ETA_KINEMATIC + GRDFLX(I,J) = SSOIL + + ! Exchange Coefficients + CHS2(I,J) = CQS2(I,J) + IF (Q1 .GT. QSFC(I,J)) THEN + CQS2(I,J) = CHS(I,J) + ENDIF + + ! Convert QSFC term back to Mixing Ratio. + QSFC(I,J) = Q1 / ( 1.0 - Q1 ) + + IF ( SEAICE_SNOWDEPTH_OPT == 1 ) THEN + SNOWSI(I,J) = SNOWONSI + ENDIF + + ! Accumulated potential evaporation. + IF ( PRESENT(POTEVP) ) THEN + POTEVP(I,J) = POTEVP(I,J) + ETP*FDTW + ENDIF + + ! Accumulated snow precipitation. + IF ( FFROZP .GT. 0.5 ) THEN + ACSNOW(I,J) = ACSNOW(I,J) + PRCP * DT + ENDIF + + ! Accumulated snow melt. + ACSNOM(I,J) = ACSNOM(I,J) + SNOMLT * 1000. + + ! Accumulated snow-melt energy. + IF ( PRESENT(SNOPCX) ) THEN + SNOPCX(I,J) = SNOPCX(I,J) - SNOMLT/FDTLIW + ENDIF + + ! Surface runoff + SFCRUNOFF(I,J) = SFCRUNOFF(I,J) + RUNOFF1 * DT * 1000.0 + + ! + ! Residual of surface energy balance terms + ! + IF ( PRESENT(NOAHRES) ) THEN + NOAHRES(I,J) = ( SOLNET + LWDN ) & + - SHEAT + SSOIL - ETA & + - ( EMISSI * STBOLT * (T1**4) ) & + - FLX1 - FLX2 - FLX3 + ENDIF +#if defined(wrfmodel) +#if (NMM_CORE != 1) + IF ( ( SF_URBAN_PHYSICS == NOAHUCMSCHEME ) .OR. & + (SF_URBAN_PHYSICS == BEPSCHEME ) .OR. & + ( SF_URBAN_PHYSICS == BEP_BEMSCHEME ) ) THEN + if ( PRESENT (B_T_BEP) ) then + B_T_BEP(I,1,J)=hfx(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP + endif + if ( PRESENT (B_Q_BEP) ) then + B_Q_BEP(I,1,J)=qfx(i,j)/dz8w(i,1,j)/rho(i,1,j) + endif + ENDIF +#endif +#endif + + enddo SEAICE_ILOOP + enddo SEAICE_JLOOP + + end subroutine seaice_noah + +end module module_sf_noah_seaice_drv diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F index 35590a5fe2..ab29ea29b8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahdrv.F @@ -1,11 +1,34 @@ +!================================================================================================================= MODULE module_sf_noahdrv +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. + !------------------------------- - USE module_sf_noahlsm - USE module_sf_urban - USE module_sf_bep - USE module_sf_bep_bem -#ifdef WRF_CHEM + USE module_sf_noahlsm, only: SFLX, XLF, XLV, CP, R_D, RHOWATER, NATURAL, SHDTBL, LUTYPE, SLTYPE, STBOLT, & + & KARMAN, LUCATS, NROTBL, RSTBL, RGLTBL, HSTBL, SNUPTBL, MAXALB, LAIMINTBL, & + & LAIMAXTBL, Z0MINTBL, Z0MAXTBL, ALBEDOMINTBL, ALBEDOMAXTBL, EMISSMINTBL, & + & EMISSMAXTBL, TOPT_DATA, CMCMAX_DATA, CFACTR_DATA, RSMAX_DATA, BARE, NLUS, & + & SLCATS, BB, DRYSMC, F11, MAXSMC, REFSMC, SATPSI, SATDK, SATDW, WLTSMC, QTZ, & + & NSLTYPE, SLPCATS, SLOPE_DATA, SBETA_DATA, FXEXP_DATA, CSOIL_DATA, & + & SALP_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, CZIL_DATA, & + & SMLOW_DATA, SMHIGH_DATA, LVCOEF_DATA, NSLOPE, & + & FRH2O,ZTOPVTBL,ZBOTVTBL, & + & LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 + USE module_sf_urban, only: urban, oasis, IRI_SCHEME + USE module_sf_noahlsm_glacial_only, only: sflx_glacial + USE module_sf_bep, only: bep + USE module_sf_bep_bem, only: bep_bem +#if defined(mpas) +use mpas_atmphys_date_time, only: cal_mon_day +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal( M ) +#else + use module_ra_gfdleta, only: cal_mon_day + use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal( M ) +#endif +#if ( WRF_CHEM == 1 ) USE module_data_gocart_dust #endif !------------------------------- @@ -17,7 +40,8 @@ MODULE module_sf_noahdrv ! Urban related variable are added to arguments - urban !---------------------------------------------------------------- SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & - HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, & + HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,SWDDIR,SWDDIF,& + GLW,SMSTAV,SMSTOT, & SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA, & ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK, & SNOWC,QSFC,RAINBL,MMINLU, & @@ -36,12 +60,15 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & XICE_THRESHOLD, & RDLAI2D,USEMONALB, & RIB, & !? - NOAHRES, & + NOAHRES,opt_thcnd, & +! Noah UA changes + ua_phys,flx4_2d,fvb_2d,fbur_2d,fgsn_2d, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & sf_urban_physics, & CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & + CMGR_SFCDIF,CHGR_SFCDIF, & !Optional Urban TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban UC_URB2D, & !H urban @@ -55,8 +82,24 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & XLAT_URB2D, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban + julian, julyr, & !H urban FRC_URB2D,UTYPE_URB2D, & !O - num_urban_layers, & !I multi-layer urban + num_urban_ndm, & !I multi-layer urban + urban_map_zrd, & !I multi-layer urban + urban_map_zwd, & !I multi-layer urban + urban_map_gd, & !I multi-layer urban + urban_map_zd, & !I multi-layer urban + urban_map_zdf, & !I multi-layer urban + urban_map_bd, & !I multi-layer urban + urban_map_wd, & !I multi-layer urban + urban_map_gbd, & !I multi-layer urban + urban_map_fbd, & !I multi-layer urban + urban_map_zgrd, & !I multi-layer urban + num_urban_hi, & !I multi-layer urban + tsk_rural_bep, & !H multi-layer urban trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban tlev_urb3d,qlev_urb3d, & !H multi-layer urban tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban @@ -65,12 +108,25 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban + ep_pv_urb3d,t_pv_urb3d, & !RMS + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS + drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS + lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !RMS + lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban + mh_urb2d,stdh_urb2d,lf_urb2d, & !SLUCM th_phy,rho,p_phy,ust, & !I multi-layer urban gmt,julday,xlong,xlat, & !I multi-layer urban a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban - dl_u_bep,sf_bep,vl_bep ) !O multi-layer urban + dl_u_bep,sf_bep,vl_bep & +#ifdef WRF_HYDRO + ,sfcheadrt,INFXSRT,soldrain & !O multi-layer urban +#endif + ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas + ,RC2,XLAI2 & + ,IRR_CHAN & + ) !---------------------------------------------------------------- IMPLICIT NONE @@ -127,6 +183,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & !-- SHDMIN minimum areal fractional coverage of annual green vegetation !-- SHDMAX maximum areal fractional coverage of annual green vegetation !-- XLAI leaf area index (dimensionless) +!-- XLAI2 leaf area index (same as XLAI) passed to output (dimensionless) !-- Z0BRD Background fixed roughness length (M) !-- Z0 Background vroughness length (M) as function !-- ZNT Time varying roughness length (M) as function @@ -159,7 +216,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & !-- ACSNOM snow melt (mm) (water equivalent) !-- ACSNOW accumulated snow fall (mm) (water equivalent) !-- SNOPCX snow phase change heat flux (W/m^2) -!-- POTEVP accumulated potential evaporation (W/m^2) +!-- POTEVP accumulated potential evaporation (m) !-- RIB Documentation needed!!! ! ---------------------------------------------------------------------- !-- RUNOFF1 surface runoff (m s-1), not infiltrating the surface @@ -168,8 +225,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3 !-- RUNOFF3 numerical trunctation in excess of porosity (smcmax) ! for a given soil layer at the end of a time step (m s-1). +!SFCRUNOFF Surface Runoff (mm) +!UDRUNOFF Total Underground Runoff (mm), which is the sum of RUNOFF2 and RUNOFF3 ! ---------------------------------------------------------------------- !-- RC canopy resistance (s m-1) +!-- RC2 canopy resistance (same as RC) passed to output !-- PC plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp !-- RSMIN minimum canopy resistance (s m-1) !-- RCS incoming solar rc factor (dimensionless) @@ -213,6 +273,18 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & INTEGER, INTENT(IN ) :: sf_urban_physics !urban INTEGER, INTENT(IN ) :: isurban INTEGER, INTENT(IN ) :: isice + INTEGER, INTENT(IN ) :: julian, julyr !urban + +!added by Wei Yu for routing +#ifdef WRF_HYDRO + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain + real :: etpnd1 +#endif +!end added + +! new local vars for hydro + REAL :: etpnd1_hydro,sfcheadrt_hydro,infxsrt_hydro REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(IN ) :: TMN, & @@ -227,7 +299,9 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & GLW, & RAINBL, & EMBCK, & - SR + SR, & + SWDDIR, & + SWDDIF REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: ALBBCK, & @@ -261,7 +335,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & TSLB ! TSLB STEMP REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & - INTENT(INOUT) :: SMCREL + INTENT(OUT) :: SMCREL REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: TSK, & !was TGB (temperature) @@ -291,15 +365,24 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ALBEDO, & ZNT REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: NOAHRES + INTENT(OUT) :: NOAHRES + INTEGER, INTENT(IN) :: OPT_THCND + +! Noah UA changes + LOGICAL, INTENT(IN) :: UA_PHYS + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: FLX4_2D,FVB_2D,FBUR_2D,FGSN_2D + REAL :: FLX4,FVB,FBUR,FGSN REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: CHKLOWQ + INTENT(OUT) :: CHKLOWQ REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: QZ0 + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: RC2, XLAI2 REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF ! Local variables (moved here from driver to make routine thread safe, 20031007 jm) @@ -423,6 +506,34 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] LOGICAL :: LSOLAR_URB + +!===Yang,2014/10/08,hydrological variable for single layer UCM=== + INTEGER :: jmonth, jday, tloc + INTEGER :: IRIOPTION, USOIL, DSOIL + REAL :: AOASIS, OMG + REAL :: DRELR_URB + REAL :: DRELB_URB + REAL :: DRELG_URB + REAL :: FLXHUMR_URB + REAL :: FLXHUMB_URB + REAL :: FLXHUMG_URB + REAL :: CMCR_URB + REAL :: TGR_URB + REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture + REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D + + ! state variable surface_driver <--> lsm <--> urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D @@ -446,24 +557,20 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D ! output variable lsm --> surface_driver - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: PSIM_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: PSIH_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GZ1OZ0_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: U10_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: V10_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TH2_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: Q2_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D ! - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: AKMS_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D ! -!ldf (01-18-2011): -! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST_URB2D -! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D -! INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST_URB2D - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D - INTEGER, OPTIONAL,DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D -!end ldf. + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FRC_URB2D + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D + ! output variables urban --> lsm REAL :: TS_URB ! surface radiative temperature [K] @@ -486,35 +593,72 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: CHS_URB REAL :: CHS2_URB REAL :: UST_URB +! NUDAPT Parameters urban --> lam + REAL :: mh_urb + REAL :: stdh_urb + REAL :: lp_urb + REAL :: hgt_urb + REAL, DIMENSION(4) :: lf_urb ! Variables for multi-layer UCM (Martilli et al. 2002) REAL, OPTIONAL, INTENT(IN ) :: GMT INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG -!ldf (01-18-2011): - INTEGER, INTENT(IN ) :: NUM_URBAN_LAYERS -! INTEGER, OPTIONAL, INTENT(IN ) :: NUM_URBAN_LAYERS -!end ldf. - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: urban_map_zgrd + INTEGER, INTENT(IN ) :: NUM_URBAN_HI + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural_bep + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d - REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ + + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: hgt_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: mh_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: stdh_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN) :: lf_urb2d REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep !Implicit momemtum component X-direction REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep !Implicit momemtum component Y-direction REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep !Implicit component pot. temperature @@ -531,30 +675,53 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep !Length scale ! Local variables for multi-layer UCM (Martilli et al. 2002) - REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL,RN_RURAL - REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_RURAL,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL - REAL, DIMENSION( ims:ime, jms:jme ) :: ALB_RURAL,EMISS_RURAL,UST_RURAL,TSK_RURAL -! REAL, DIMENSION( ims:ime, jms:jme ) :: GRDFLX_URB -! REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_URB,QSFC_URB,UMOM_URB,VMOM_URB - REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_URB,UMOM_URB,VMOM_URB - REAL, DIMENSION( ims:ime, jms:jme ) :: QFX_URB + REAL, DIMENSION( its:ite, jts:jte ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL ! ,RN_RURAL + REAL, DIMENSION( its:ite, jts:jte ) :: QFX_RURAL ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL + REAL, DIMENSION( its:ite, jts:jte ) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL +! REAL, DIMENSION( ims:ime, jms:jme ) :: QSFC_URB + REAL, DIMENSION( its:ite, jts:jte ) :: HFX_URB,UMOM_URB,VMOM_URB + REAL, DIMENSION( its:ite, jts:jte ) :: QFX_URB ! REAL, DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST - REAL, DIMENSION(ims:ime,jms:jme) ::EMISS_URB - REAL, DIMENSION(ims:ime,jms:jme) :: RL_UP_URB - REAL, DIMENSION(ims:ime,jms:jme) ::RS_ABS_URB - REAL, DIMENSION(ims:ime,jms:jme) ::GRDFLX_URB + REAL, DIMENSION(its:ite,jts:jte) ::EMISS_URB + REAL, DIMENSION(its:ite,jts:jte) :: RL_UP_URB + REAL, DIMENSION(its:ite,jts:jte) ::RS_ABS_URB + REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM - REAL :: r1,r2,r3 - REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB + REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB + REAL :: frc_urb,lb_urb + REAL :: check ! ---------------------------------------------------------------------- ! DECLARATIONS END - urban ! ---------------------------------------------------------------------- REAL, PARAMETER :: CAPA=R_D/CP REAL :: APELM,APES,SFCTH2,PSFC - real, intent(in) :: xice_threshold character(len=80) :: message_text +! +! FASDAS +! + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & + INTENT(INOUT) :: SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM + INTEGER, INTENT(IN ) :: fasdas +! local vars + REAL :: XSDA_HFX, XSDA_QFX, XQNORM + REAL :: HFX_PHY, QFX_PHY + REAL :: DZQ + REAL :: HCPCT_FASDAS + + REAL,OPTIONAL,INTENT(IN),DIMENSION( ims:ime, jms:jme ) :: IRR_CHAN + REAL :: IRRIGATION_CHANNEL + IRRIGATION_CHANNEL =0.0 + HFX_PHY = 0.0 ! initialize + QFX_PHY = 0.0 + XQNORM = 0.0 + XSDA_HFX = 0.0 + XSDA_QFX = 0.0 +! +! END FASDAS +! + sigma_sb=5.67e-08 ! MEK MAY 2007 FDTLIW=DT/ROWLIW @@ -574,7 +741,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & SLDPTH(NS)=DZS(NS) ENDDO - DO J=jts,jte + JLOOP : DO J=jts,jte IF(ITIMESTEP.EQ.1)THEN DO 50 I=its,ite @@ -618,13 +785,19 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ! end of initialization over ocean !----------------------------------------------------------------------- - DO 100 I=its,ite + ILOOP : DO I=its,ite ! surface pressure PSFC=P8w3D(i,1,j) ! pressure in middle of lowest layer SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5 ! convert from mixing ratio to specific humidity Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j)) +! initializing local variables + SOILW=0. + FLX4=0. + FVB=0. + FBUR=0. + FGSN=0. ! ! Q2SAT=QGH(I,j) Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity @@ -657,6 +830,13 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! use mid-day albedo to determine net downward solar (no solar zenith angle correction) SOLNET=SOLDN*(1.-ALBEDO(I,J)) PRCP=RAINBL(i,j)/DT + IF(PRESENT(IRR_CHAN)) THEN + IF(IRR_CHAN(i,j).NE.0) THEN + IRRIGATION_CHANNEL=IRR_CHAN(i,j)/DT + ELSE + IRRIGATION_CHANNEL=0. + END IF + ENDIF VEGTYP=IVGTYP(I,J) SOILTYP=ISLTYP(I,J) SHDFAC=VEGFRA(I,J)/100. @@ -691,6 +871,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & LH_RURAL(I,J)=LH(I,J) EMISS_RURAL(I,J)=EMISS(I,J) GRDFLX_RURAL(I,J)=GRDFLX(I,J) + ELSE ! Land or sea-ice case @@ -722,19 +903,19 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & DQSDT2=Q2SATI*6174./(SFCTSNO**2) ENDIF ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero - IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J)) +! V3.8 add condition for SWDOWN to restrict condition to positive forcing (JD) + IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0. .AND. SWDOWN(I,J) .GT. 10.)DQSDT2=DQSDT2*(1.-SNOWC(I,J)) ENDIF - IF(ICE.EQ.1)THEN - ! Sea-ice point has deep-level temperature of -2 C - TBOT=271.16 - ELSE - ! Land-ice or land points have the usual deep-soil temperature. - TBOT=TMN(I,J) - ENDIF + ! Land-ice or land points use the usual deep-soil temperature. + TBOT=TMN(I,J) + + IF(ISURBAN.EQ.1) THEN +! assumes these only need to be set for USGS land data IF(VEGTYP.EQ.25) SHDFAC=0.0000 IF(VEGTYP.EQ.26) SHDFAC=0.0000 IF(VEGTYP.EQ.27) SHDFAC=0.0000 + ENDIF IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN #if 0 IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' @@ -743,7 +924,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & SOILTYP=7 ENDIF SNOALB1 = SNOALB(I,J) - CMC=CANWAT(I,J) +! converts canwat in mm to CMC in meters + CMC=CANWAT(I,J)/1000. !------------------------------------------- !*** convert snow depth from mm to meter @@ -763,11 +945,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & RIBB=RIB(I,J) !FEI: temporaray arrays above need to be changed later by using SI - DO 70 NS=1,NSOIL + DO NS=1,NSOIL SMC(NS)=SMOIS(I,NS,J) STC(NS)=TSLB(I,NS,J) !STEMP SWC(NS)=SH2O(I,NS,J) - 70 CONTINUE + ENDDO ! if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN SNOWHK= 5.*SNEQV @@ -776,35 +958,78 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as ! the "NATURAL" category in the VEGPARM.TBL + IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN - IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN VEGTYP = NATURAL SHDFAC = SHDTBL(NATURAL) ALBEDOK =0.2 ! 0.2 ALBBRD =0.2 !0.2 EMISSI = 0.98 !for VEGTYP=5 + LWDN = GLW(I,J) * EMISSI + SOLNET = SOLDN * (1.0 - ALBEDOK) + IF ( FRC_URB2D(I,J) < 0.99 ) THEN if(sf_urban_physics.eq.1)then - T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) + T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then - r1= (tsk(i,j)**4.) - r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.) - r3= (1.-frc_urb2d(i,j)) - t1= ((r1-r2)/r3)**.25 + T1=tsk_rural_bep(i,j) endif ELSE T1 = TSK(I,J) ENDIF ENDIF ELSE - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN VEGTYP = ISURBAN - ENDIF + ENDIF + + ENDIF + +!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== + AOASIS = 1.0 + USOIL = 1 + DSOIL = 2 + IRIOPTION=IRI_SCHEME + IF(SF_URBAN_PHYSICS == 1) THEN + OMG= OMG_URB2D(I,J) + tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24) + if (tloc.lt.0) tloc=tloc+24 + if (tloc==0) tloc=24 + CALL cal_mon_day(julian,julyr,jmonth,jday) + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + AOASIS = oasis ! urban oasis effect + IF (IRIOPTION ==1) THEN + IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm + IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN +! IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= SMCREF +! IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= SMCREF + IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J)) + IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J)) + ENDIF + ENDIF + ENDIF + ENDIF ENDIF + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + IF(AOASIS > 1.0) THEN + FATAL_ERROR('Urban oasis option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + IF(IRIOPTION == 1) THEN + FATAL_ERROR('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + ENDIF + #if 0 IF(IPRINT) THEN ! @@ -831,35 +1056,136 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & endif #endif - IF (rdlai2d) THEN + IF (SHDFAC > 0.0 .AND. LAI(I,J) <= 0.0) LAI(I,J) = 0.01 xlai = lai(i,j) endif - CALL SFLX (FFROZP, ICE, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C - LOCAL, & !L - LUTYPE, SLTYPE, & !CL - LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F - DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used - TH2,Q2SAT,DQSDT2, & !I - VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I - ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + IF ( ICE == 1 ) THEN + + ! Sea-ice case + + DO NS = 1, NSOIL + SH2O(I,NS,J) = 1.0 + ENDDO + LAI(I,J) = 0.01 + + CYCLE ILOOP + + ELSEIF (ICE == 0) THEN + + ! Non-glacial land +! +! FASDAS +! + IF( fasdas == 1 ) THEN + + DZQ = DZ8W(I,1,J) + XSDA_HFX= SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZQ ! W/m^2 + ! TWG2015 Bugfix remove factor of 1000.0 for correct units + XSDA_QFX= SDA_QFX(I,J)*RHO(I,1,J)*DZQ ! Kg/m2/s of water + XQNORM = QNORM(I,J) + + ENDIF +! +! END FASDAS +! +#ifdef WRF_HYDRO + etpnd1_hydro = 0. + sfcheadrt_hydro = sfcheadrt(i,j) + infxsrt_hydro = infxsrt(i,j) +#else + etpnd1_hydro = 0. + sfcheadrt_hydro = 0. + infxsrt_hydro = 0. +#endif + CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H - ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O - EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O - BETA,ETP,SSOIL, & !O - FLX1,FLX2,FLX3, & !O - SNOMLT,SNCOVR, & !O - RUNOFF1,RUNOFF2,RUNOFF3, & !O - RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O - SOILW,SOILM,Q1,SMAV, & !D - RDLAI2D,USEMONALB, & - SNOTIME1, & - RIBB, & - SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & +! WRF_HYDRO vars + sfcheadrt_hydro, & !I + INFXSRT_hydro,ETPND1_hydro & !O + ,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas + ,IRRIGATION_CHANNEL) + +#ifdef WRF_HYDRO + soldrain(i,j) = RUNOFF2*DT*1000.0 + sfcheadrt(i,j) = sfcheadrt_hydro + infxsrt(i,j) = INFXSRT_hydro + etpnd1 = etpnd1_hydro +#endif + ELSEIF (ICE == -1) THEN + + ! + ! Set values that the LSM is expected to update, + ! but don't get updated for glacial points. + ! + SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero + XLAI = 0.01 ! KWM Should this be Zero over land ice? Does this value matter? + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + DO NS = 1, NSOIL + SWC(NS) = 1.0 + SMC(NS) = 1.0 + SMAV(NS) = 1.0 + ENDDO +! +! FASDAS +! + IF( fasdas == 1 ) THEN + + DZQ = DZ8W(I,1,J) + XSDA_HFX= SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZQ ! W/m^2 + XSDA_QFX= 0.0 ! Kg/m2/s of water + XQNORM = 0.0 + + ENDIF +! +! END FASDAS +! + CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C + & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F + & TH2,Q2SAT,DQSDT2, & !I + & ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + & T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK, & !H + & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O + & ESNOW,DEW, & !O + & ETP,SSOIL, & !O + & FLX1,FLX2,FLX3, & !O + & SNOMLT,SNCOVR, & !O + & RUNOFF1, & !O + & Q1, & !D + & SNOTIME1, & + & RIBB) + + ENDIF lai(i,j) = xlai + if (present(rc2) .and. present(xlai2)) then + rc2(I,J) = RC ! for output + xlai2(I,J) = XLAI + endif #if 0 IF(IPRINT) THEN @@ -888,7 +1214,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & #endif !*** UPDATE STATE VARIABLES - CANWAT(I,J)=CMC + CANWAT(I,J)=CMC*1000. SNOW(I,J)=SNEQV*1000. ! SNOWH(I,J)=SNOWHK*1000. SNOWH(I,J)=SNOWHK ! SNOWHK in meters @@ -898,16 +1224,46 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & Z0(I,J)=Z0BRD EMISS(I,J) = EMISSI EMISS_RURAL(I,J) = EMISSI -! MEK Nov2006 turn off -! ZNT(I,J)=Z0K +! Noah: activate time-varying roughness length (V3.3 Feb 2011) + ZNT(I,J)=Z0K +! +! FASDAS +! +! Update Skin Temperature + IF( fasdas == 1 ) THEN + XSDA_QFX= XSDA_QFX*ELWV*XQNORM + + !TWG2015 Bugfix to multiply Heat Capacity by Soil Depth for correct + !units + + T1 = T1 + (XSDA_HFX-XSDA_QFX)*DT/(HCPCT_FASDAS*DZS(1)) + + END IF +! +! END FASDAS +! TSK(I,J)=T1 TSK_RURAL(I,J)=T1 + if (present(tsk_rural_bep)) then + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + TSK_RURAL_BEP(I,J)=T1 + END IF + endif HFX(I,J)=SHEAT HFX_RURAL(I,J)=SHEAT ! MEk Jul07 add potential evap accum POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW QFX(I,J)=ETA_KINEMATIC QFX_RURAL(I,J)=ETA_KINEMATIC + +#ifdef WRF_HYDRO +!added by Wei Yu +! QFX(I,J) = QFX(I,J) + ETPND1 +! ETA = ETA + ETPND1/2.501E6*dt +!end added by Wei Yu +#endif + + LH(I,J)=ETA LH_RURAL(I,J)=ETA GRDFLX(I,J)=SSOIL @@ -918,14 +1274,15 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! prevent diagnostic ground q (q1) from being greater than qsat(tsk) ! as happens over snow cover where the cqs2 value also becomes irrelevant ! by setting cqs2=chs in this situation the 2m q should become just qv(k=1) - IF (Q1 .GT. QSFC(I,J)) THEN - CQS2(I,J) = CHS(I,J) - ENDIF +! ww: comment out this change to avoid Q2 drop due to change of radiative flux +! IF (Q1 .GT. QSFC(I,J)) THEN +! CQS2(I,J) = CHS(I,J) +! ENDIF ! QSFC(I,J)=Q1 ! Convert QSFC back to mixing ratio QSFC(I,J)= Q1/(1.0-Q1) ! - QSFC_RURAL(I,J)= Q1/(1.0-Q1) + ! QSFC_RURAL(I,J)= Q1/(1.0-Q1) ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002) DO 80 NS=1,NSOIL @@ -935,10 +1292,23 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & 80 CONTINUE ! ENDIF + FLX4_2D(I,J) = FLX4 + FVB_2D(I,J) = FVB + FBUR_2D(I,J) = FBUR + FGSN_2D(I,J) = FGSN + ! ! Residual of surface energy balance equation terms ! - noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 + + IF ( UA_PHYS ) THEN + noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta & + - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4 + + ELSE + noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta & + - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 + ENDIF IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block @@ -947,9 +1317,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & !-------------------------------------- ! Input variables lsm --> urban + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN ! Call urban @@ -966,7 +1338,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & SSGD_URB = 0.8*SOLDN ! [W/m/m] SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] LLG_URB = GLW(I,J) ! [W/m/m] - RAIN_URB = RAINBL(I,J) ! [mm] + RAIN_URB = RAINBL(I,J) / DT * 3600.0 ! [mm/hr] RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] ZA_URB = ZLVL ! [m] DELT_URB = DT ! [sec] @@ -984,8 +1356,19 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & QC_URB = QC_URB2D(I,J) UC_URB = UC_URB2D(I,J) + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) + DO K = 1,num_roof_layers TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) END DO DO K = 1,num_wall_layers TBL_URB(K) = TBL_URB3D(I,K,J) @@ -1016,12 +1399,30 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_URB = CMR_SFCDIF(I,J) CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) CMC_URB = CMC_SFCDIF(I,J) CHC_URB = CHC_SFCDIF(I,J) ENDIF + +! NUDAPT for SLUCM + mh_urb = mh_urb2d(I,J) + stdh_urb = stdh_urb2d(I,J) + lp_urb = lp_urb2d(I,J) + hgt_urb = hgt_urb2d(I,J) + lf_urb = 0.0 + DO K = 1,4 + lf_urb(K)=lf_urb2d(I,K,J) + ENDDO + frc_urb = frc_urb2d(I,J) + lb_urb = lb_urb2d(I,J) + check = 0 + if (I.eq.73.and.J.eq.125)THEN + check = 1 + end if ! ! Call urban - + CALL cal_mon_day(julian,julyr,jmonth,jday) CALL urban(LSOLAR_URB, & ! I num_roof_layers,num_wall_layers,num_road_layers, & ! C DZR,DZB,DZG, & ! C @@ -1038,7 +1439,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & GZ1OZ0_URB, & !O CMR_URB, CHR_URB, CMC_URB, CHC_URB, & U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O - UST_URB) !O + UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) #if 0 IF(IPRINT) THEN @@ -1108,8 +1513,19 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & QC_URB2D(I,J) = QC_URB UC_URB2D(I,J) = UC_URB + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + DO K = 1,num_roof_layers TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) END DO DO K = 1,num_wall_layers TBL_URB3D(I,K,J) = TBL_URB(K) @@ -1138,6 +1554,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_SFCDIF(I,J) = CMR_URB CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB CMC_SFCDIF(I,J) = CMC_URB CHC_SFCDIF(I,J) = CHC_URB ENDIF @@ -1154,9 +1572,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & DO NS=1,NSOIL SMCREL(I,NS,J)=SMAV(NS) ENDDO + + ! Convert the water unit into mm SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0 - UDRUNOFF(I,J)=UDRUNOFF(I,J)+(RUNOFF2+RUNOFF3)*DT*1000.0 + UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0 ! snow defined when fraction of frozen precip (FFROZP) > 0.5, IF(FFROZP.GT.0.5)THEN ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT @@ -1169,9 +1589,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ! endif of land-sea test - 100 CONTINUE ! of I loop - - ENDDO ! of J loop + ENDDO ILOOP ! of I loop + ENDDO JLOOP ! of J loop IF (SF_URBAN_PHYSICS == 2) THEN @@ -1182,17 +1601,21 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & RL_UP_URB(i,j)=0. RS_ABS_URB(i,j)=0. GRDFLX_URB(i,j)=0. + b_q_bep(i,kts:kte,j)=0. end do end do CALL BEP(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, & th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & a_u_bep,a_v_bep,a_t_bep, & a_e_bep,b_u_bep,b_v_bep, & - b_t_bep,b_e_bep,dlg_bep, & + b_t_bep,b_e_bep,b_q_bep,dlg_bep, & dl_u_bep,sf_bep,vl_bep, & rl_up_urb,rs_abs_urb,emiss_urb,grdflx_urb, & ids,ide, jds,jde, kds,kde, & @@ -1211,19 +1634,29 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & RL_UP_URB(i,j)=0. RS_ABS_URB(i,j)=0. GRDFLX_URB(i,j)=0. + b_q_bep(i,kts:kte,j)=0. end do end do - + + CALL BEP_BEM(frc_urb2d,utype_urb2d,itimestep,dz8w,dt,u_phy,v_phy, & th_phy,rho,p_phy,swdown,glw, & gmt,julday,xlong,xlat,declin_urb,cosz_urb2d,omg_urb2d, & - num_urban_layers, & + num_urban_ndm, urban_map_zrd, urban_map_zwd, urban_map_gd, & + urban_map_zd, urban_map_zdf, urban_map_bd, urban_map_wd, & + urban_map_gbd, urban_map_fbd, urban_map_zgrd, num_urban_hi, & trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d, & tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d, & cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d, & sfwin1_urb3d,sfwin2_urb3d, & sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & + ep_pv_urb3d,t_pv_urb3d, & !RMS + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS + drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS + lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d, & !RMS + rainbl,swddir,swddif, & !RMS + lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & a_u_bep,a_v_bep,a_t_bep, & a_e_bep,b_u_bep,b_v_bep, & b_t_bep,b_e_bep,b_q_bep,dlg_bep, & @@ -1236,8 +1669,6 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF if((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then !Bep begin -! fix the value of the Stefan-Boltzmann constant - sigma_sb=5.67e-08 do j=jts,jte do i=its,ite UMOM_URB(I,J)=0. @@ -1288,8 +1719,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & rl_up_rural=-emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j) rl_up_tot=(1.-frc_urb2d(i,j))*rl_up_rural+frc_urb2d(i,j)*rl_up_urb(i,j) emiss(i,j)=(1.-frc_urb2d(i,j))*emiss_rural(i,j)+frc_urb2d(i,j)*emiss_urb(i,j) - ts_urb2d(i,j)=((-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb)**0.25 - tsk(i,j)=( (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb)**.25 + ts_urb2d(i,j)=(max(0.,(-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb))**0.25 + tsk(i,j)=(max(0., (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb))**.25 rs_abs_tot=(1.-frc_urb2d(i,j))*swdown(i,j)*(1.-albedo(i,j))+frc_urb2d(i,j)*rs_abs_urb(i,j) if(swdown(i,j).gt.0.)then albedo(i,j)=1.-rs_abs_tot/swdown(i,j) @@ -1306,7 +1737,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & LH_URB2D(I,J) = qfx_urb(i,j)*xlv G_URB2D(I,J) = grdflx_urb(i,j) RN_URB2D(I,J) = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j) - ust(i,j)=(umom**2.+vmom**2.)**.25 + ust(i,j)=(umom**2.+vmom**2.)**.25 ! if(tsk(i,j).gt.350)write(*,*)'tsk too big!',i,j,tsk(i,j) ! if(tsk(i,j).lt.260)write(*,*)'tsk too small!',i,j,tsk(i,j),rl_up_tot,rl_up_urb(i,j),rl_up_rural ! print*,'ivgtyp,i,j,sigma_sb',ivgtyp(i,j),i,j,sigma_sb @@ -1331,33 +1762,21 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & G_URB2D(I,J) = 0. RN_URB2D(I,J) = 0. endif -! IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & -! IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN -! print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j) -! print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j) -! print*,'lh,lh_rural',lh(i,j),lh_rural(i,j) -! print*,'qfx',qfx(i,j) -! print*,'ts_urb2d',ts_urb2d(i,j) -! print*,'ust',ust(i,j) -! endif enddo enddo - endif !Bep end !------------------------------------------------------ END SUBROUTINE lsm !------------------------------------------------------ -!ldf (01-04-2011): This section of the module is moved to module_physics_lsm_noahinit.F in +!For MPAS, the below section of the module is moved to module_physics_lsm_noahinit.F in !./../core_physics to accomodate differences in the mpi calls between WRF and MPAS.I thought !that it would be cleaner to do this instead of adding a lot of #ifdef statements throughout !the initialization subroutine. -#if !defined(mpas) - - +#if defined(wrfmodel) SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, & ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, & @@ -1365,9 +1784,11 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & SNOALB, FNDSOILW, FNDSNOWH, RDMAXALB, & num_soil_layers, restart, & allowed_to_read , & + irr_rand_field,irr_ph,irr_freq, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte & + ) INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1413,28 +1834,52 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & REAL, PARAMETER :: BLIM = 5.5, HLICE = 3.335E5, & GRAV = 9.81, T0 = 273.15 INTEGER :: errflag - + CHARACTER(LEN=80) :: err_message + INTEGER,DIMENSION(ims:ime, jms:jme ),INTENT(INOUT):: irr_rand_field + INTEGER , DIMENSION(jds:jde) :: my_seeds + INTEGER :: irr_ph,irr_freq + REAL,DIMENSION(ims:ime, jms:jme ) :: rand_tmp character*256 :: MMINSL MMINSL='STAS' ! ! initialize three Noah LSM related tables IF ( allowed_to_read ) THEN -! CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' ) + CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' ) CALL SOIL_VEG_GEN_PARM( MMINLU, MMINSL ) ENDIF -#ifdef WRF_CHEM -! -! need this parameter for dust parameterization in wrf/chem -! - do I=1,NSLTYPE - porosity(i)=maxsmc(i) - enddo -#endif +! GAC--> +! 20130219 - No longer need these - see module_data_gocart_dust +!#if ( WRF_CHEM == 1 ) +!! +!! need this parameter for dust parameterization in wrf/chem +!! +! do I=1,NSLTYPE +! porosity(i)=maxsmc(i) +! drypoint(i)=drysmc(i) +! enddo +!#endif +! <--GAC IF(.not.restart)THEN +#if ( EM_CORE==1 ) + IF (irr_ph.NE.0)THEN + DO i = its,ite + DO j=jts,jte + my_seeds(j) =sqrt(ide*(real(j-1)**2))+sqrt(real(jde*i)) +! PRINT*,'myseed', my_seeds(j),j,jts,jds + END DO + CALL RANDOM_SEED ( PUT = my_seeds ) + CALL RANDOM_NUMBER ( rand_tmp(i,:) ) + CALL RANDOM_SEED ( GET = my_seeds ) + CALL RANDOM_NUMBER ( rand_tmp(i,:) ) + irr_rand_field(i,:)=int(modulo(rand_tmp(i,:)*100,real(irr_freq))) + END DO + END IF +#endif + itf=min0(ite,ide-1) jtf=min0(jte,jde-1) @@ -1443,7 +1888,7 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & DO i = its,itf IF ( ISLTYP( i,j ) .LT. 1 ) THEN errflag = 1 - WRITE(err_message,*)"module_sf_noahlsm.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) + WRITE(err_message,*)"module_sf_noahdrv.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) CALL wrf_message(err_message) ENDIF IF(.not.RDMAXALB) THEN @@ -1452,8 +1897,13 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & ENDDO ENDDO IF ( errflag .EQ. 1 ) THEN - CALL wrf_error_fatal( "module_sf_noahlsm.F: lsminit: out of range value "// & +#if ( HWRF == 1 ) + CALL wrf_message( "WARNING: message only; was fatal. module_sf_noahdrv.F: lsminit: out of range value "// & + "of ISLTYP. Is this field in the input?" ) +#else + CALL wrf_error_fatal( "module_sf_noahdrv.F: lsminit: out of range value "// & "of ISLTYP. Is this field in the input?" ) +#endif ENDIF ! initialize soil liquid water content SH2O @@ -1541,7 +1991,7 @@ END SUBROUTINE lsminit SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) !----------------------------------------------------------------- -! USE module_wrf_error + USE module_wrf_error IMPLICIT NONE CHARACTER(LEN=*), INTENT(IN) :: MMINLU, MMINSL @@ -1550,7 +2000,10 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) INTEGER , PARAMETER :: OPEN_OK = 0 character*128 :: mess , message + character*256 :: a_string logical, external :: wrf_dm_on_monitor + integer , parameter :: loop_max = 10 + integer :: loop_count !-----SPECIFY VEGETATION RELATED CHARACTERISTICS : @@ -1589,8 +2042,9 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) LUMATCH=0 + loop_count = 0 + READ (19,FMT='(A)',END=2002) a_string FIND_LUTYPE : DO WHILE (LUMATCH == 0) - READ (19,*,END=2002) READ (19,*,END=2002)LUTYPE READ (19,*)LUCATS,IINDEX @@ -1599,10 +2053,16 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_message( mess ) LUMATCH=1 ELSE + loop_count = loop_count+1 call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) ) - DO LC = 1, LUCATS+12 - read(19,*) - ENDDO + FIND_VEGETATION_PARAMETER_FLAG : DO + READ (19,FMT='(A)', END=2002) a_string + IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN + EXIT FIND_VEGETATION_PARAMETER_FLAG + ELSE IF ( loop_count .GE. loop_max ) THEN + CALL wrf_error_fatal ( 'Too many loops in VEGPARM.TBL') + ENDIF + ENDDO FIND_VEGETATION_PARAMETER_FLAG ENDIF ENDDO FIND_LUTYPE ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 @@ -1619,6 +2079,8 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) SIZE(Z0MAXTBL) < LUCATS .OR. & SIZE(ALBEDOMINTBL) < LUCATS .OR. & SIZE(ALBEDOMAXTBL) < LUCATS .OR. & + SIZE(ZTOPVTBL) < LUCATS .OR. & + SIZE(ZBOTVTBL) < LUCATS .OR. & SIZE(EMISSMINTBL ) < LUCATS .OR. & SIZE(EMISSMAXTBL ) < LUCATS ) THEN CALL wrf_error_fatal('Table sizes too small for value of LUCATS in module_sf_noahdrv.F') @@ -1631,7 +2093,8 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) SNUPTBL(LC),MAXALB(LC), LAIMINTBL(LC), & LAIMAXTBL(LC),EMISSMINTBL(LC), & EMISSMAXTBL(LC), ALBEDOMINTBL(LC), & - ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(LC) + ALBEDOMAXTBL(LC), Z0MINTBL(LC), Z0MAXTBL(LC),& + ZTOPVTBL(LC), ZBOTVTBL(LC) ENDDO ! READ (19,*) @@ -1646,8 +2109,35 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) READ (19,*)BARE READ (19,*) READ (19,*)NATURAL + READ (19,*) + READ (19,*) + READ (19,FMT='(A)') a_string + IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN + CALL wrf_message ("Expected low and high density residential, and high density industrial information in VEGPARM.TBL") + CALL wrf_error_fatal ("This could be caused by using an older VEGPARM.TBL file with a newer WRF source code.") + ENDIF + READ (19,*)LCZ_1 + READ (19,*) + READ (19,*)LCZ_2 + READ (19,*) + READ (19,*)LCZ_3 + READ (19,*) + READ (19,*)LCZ_4 + READ (19,*) + READ (19,*)LCZ_5 + READ (19,*) + READ (19,*)LCZ_6 + READ (19,*) + READ (19,*)LCZ_7 + READ (19,*) + READ (19,*)LCZ_8 + READ (19,*) + READ (19,*)LCZ_9 + READ (19,*) + READ (19,*)LCZ_10 + READ (19,*) + READ (19,*)LCZ_11 ENDIF -! 2002 CONTINUE CLOSE (19) @@ -1674,6 +2164,8 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_dm_bcast_real ( EMISSMAXTBL , NLUS ) CALL wrf_dm_bcast_real ( ALBEDOMINTBL , NLUS ) CALL wrf_dm_bcast_real ( ALBEDOMAXTBL , NLUS ) + CALL wrf_dm_bcast_real ( ZTOPVTBL , NLUS ) + CALL wrf_dm_bcast_real ( ZBOTVTBL , NLUS ) CALL wrf_dm_bcast_real ( MAXALB , NLUS ) CALL wrf_dm_bcast_real ( TOPT_DATA , 1 ) CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) @@ -1681,6 +2173,17 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) CALL wrf_dm_bcast_integer ( BARE , 1 ) CALL wrf_dm_bcast_integer ( NATURAL , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_1 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_2 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_3 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_4 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_5 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_6 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_7 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_8 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_9 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_10 , 1 ) + CALL wrf_dm_bcast_integer ( LCZ_11 , 1 ) ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL @@ -1693,7 +2196,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_error_fatal ( message ) END IF - WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICAION = ', TRIM ( MMINSL ) + WRITE(mess,*) 'INPUT SOIL TEXTURE CLASSIFICATION = ', TRIM ( MMINSL ) CALL wrf_message( mess ) LUMATCH=0 @@ -1829,6 +2332,3004 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) END SUBROUTINE SOIL_VEG_GEN_PARM !----------------------------------------------------------------- +!=========================================================================== +! +! subroutine lsm_mosaic: a tiling approach for Noah LSM +! +!=========================================================================== + +SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & + HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, & + SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA, & + ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK, & + SNOWC,QSFC,RAINBL,MMINLU, & + num_soil_layers,DT,DZS,ITIMESTEP, & + SMOIS,TSLB,SNOW,CANWAT, & + CHS,CHS2,CQS2,CPM,ROVCP,SR,chklowq,lai,qz0, & !H + myj,frpcpn, & + SH2O,SNOWH, & !H + U_PHY,V_PHY, & !I + SNOALB,SHDMIN,SHDMAX, & !I + SNOTIME, & !? + ACSNOM,ACSNOW, & !O + SNOPCX, & !O + POTEVP, & !O + SMCREL, & !O + XICE_THRESHOLD, & + RDLAI2D,USEMONALB, & + RIB, & !? + NOAHRES,OPT_THCND, & + NLCAT,landusef,landusef2, & ! danli mosaic + sf_surface_mosaic,mosaic_cat,mosaic_cat_index, & ! danli mosaic + TSK_mosaic,QSFC_mosaic, & ! danli mosaic + TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic, & ! danli mosaic + CANWAT_mosaic,SNOW_mosaic, & ! danli mosaic + SNOWH_mosaic,SNOWC_mosaic, & ! danli mosaic + ALBEDO_mosaic,ALBBCK_mosaic, & ! danli mosaic + EMISS_mosaic, EMBCK_mosaic, & ! danli mosaic + ZNT_mosaic, Z0_mosaic, & ! danli mosaic + HFX_mosaic,QFX_mosaic, & ! danli mosaic + LH_mosaic, GRDFLX_mosaic, SNOTIME_mosaic, & ! danli mosaic + RC_mosaic, LAI_mosaic, & +! Noah UA changes + ua_phys,flx4_2d,fvb_2d,fbur_2d,fgsn_2d, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + sf_urban_physics, & + CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & + CMGR_SFCDIF,CHGR_SFCDIF, & +!Optional Urban + TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban + UC_URB2D, & !H urban + XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !H urban + TRL_URB3D,TBL_URB3D,TGL_URB3D, & !H urban + SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D, & !H urban + TR_URB2D_mosaic,TB_URB2D_mosaic, & !H urban danli mosaic + TG_URB2D_mosaic,TC_URB2D_mosaic, & !H urban danli mosaic + QC_URB2D_mosaic,UC_URB2D_mosaic, & !H urban danli mosaic + TRL_URB3D_mosaic,TBL_URB3D_mosaic, & !H urban danli mosaic + TGL_URB3D_mosaic, & !H urban danli mosaic + SH_URB2D_mosaic,LH_URB2D_mosaic, & !H urban danli mosaic + G_URB2D_mosaic,RN_URB2D_mosaic, & !H urban danli mosaic + TS_URB2D_mosaic, & !H urban danli mosaic + TS_RUL2D_mosaic, & !H urban danli mosaic + PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D, & !O urban + GZ1OZ0_URB2D, AKMS_URB2D, & !O urban + TH2_URB2D,Q2_URB2D, UST_URB2D, & !O urban + DECLIN_URB,COSZ_URB2D,OMG_URB2D, & !I urban + XLAT_URB2D, & !I urban + num_roof_layers, num_wall_layers, & !I urban + num_road_layers, DZR, DZB, DZG, & !I urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban + julian,julyr, & !H urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban + FRC_URB2D,UTYPE_URB2D, & !O + num_urban_ndm, & !I multi-layer urban + urban_map_zrd, & !I multi-layer urban + urban_map_zwd, & !I multi-layer urban + urban_map_gd, & !I multi-layer urban + urban_map_zd, & !I multi-layer urban + urban_map_zdf, & !I multi-layer urban + urban_map_bd, & !I multi-layer urban + urban_map_wd, & !I multi-layer urban + urban_map_gbd, & !I multi-layer urban + urban_map_fbd, & !I multi-layer urban + urban_map_zgrd, & !I multi-layer urban + num_urban_hi, & !I multi-layer urban + use_wudapt_lcz, & !I wudapt + tsk_rural_bep, & !H multi-layer urban + trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d, & !H multi-layer urban + tlev_urb3d,qlev_urb3d, & !H multi-layer urban + tw1lev_urb3d,tw2lev_urb3d, & !H multi-layer urban + tglev_urb3d,tflev_urb3d, & !H multi-layer urban + sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d, & !H multi-layer urban + sfvent_urb3d,lfvent_urb3d, & !H multi-layer urban + sfwin1_urb3d,sfwin2_urb3d, & !H multi-layer urban + sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d, & !H multi-layer urban + ep_pv_urb3d,t_pv_urb3d, & !RMS + trv_urb4d,qr_urb4d,qgr_urb3d,tgr_urb3d, & !RMS + drain_urb4d,draingr_urb3d,sfrv_urb3d, & !RMS + lfrv_urb3d,dgr_urb3d,dg_urb3d,lfr_urb3d,lfg_urb3d,& !RMS + lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d, & !H multi-layer urban + mh_urb2d,stdh_urb2d,lf_urb2d, & !SLUCM + th_phy,rho,p_phy,ust, & !I multi-layer urban + gmt,julday,xlong,xlat, & !I multi-layer urban + a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban + a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban + b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban + dl_u_bep,sf_bep,vl_bep & !O multi-layer urban +#ifdef WRF_HYDRO + ,sfcheadrt,INFXSRT, soldrain & !hydro +#endif + ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas + ,RC2,XLAI2 & !O + ,IRR_CHAN & + ) + +!---------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------- +!---------------------------------------------------------------- +! --- atmospheric (WRF generic) variables +!-- DT time step (seconds) +!-- DZ8W thickness of layers (m) +!-- T3D temperature (K) +!-- QV3D 3D water vapor mixing ratio (Kg/Kg) +!-- P3D 3D pressure (Pa) +!-- FLHC exchange coefficient for heat (m/s) +!-- FLQC exchange coefficient for moisture (m/s) +!-- PSFC surface pressure (Pa) +!-- XLAND land mask (1 for land, 2 for water) +!-- QGH saturated mixing ratio at 2 meter +!-- GSW downward short wave flux at ground surface (W/m^2) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- History variables +!-- CANWAT canopy moisture content (mm) +!-- TSK surface temperature (K) +!-- TSLB soil temp (k) +!-- SMOIS total soil moisture content (volumetric fraction) +!-- SH2O unfrozen soil moisture content (volumetric fraction) +! note: frozen soil moisture (i.e., soil ice) = SMOIS - SH2O +!-- SNOWH actual snow depth (m) +!-- SNOW liquid water-equivalent snow depth (m) +!-- ALBEDO time-varying surface albedo including snow effect (unitless fraction) +!-- ALBBCK background surface albedo (unitless fraction) +!-- CHS surface exchange coefficient for heat and moisture (m s-1); +!-- CHS2 2m surface exchange coefficient for heat (m s-1); +!-- CQS2 2m surface exchange coefficient for moisture (m s-1); +! --- soil variables +!-- num_soil_layers the number of soil layers +!-- ZS depths of centers of soil layers (m) +!-- DZS thicknesses of soil layers (m) +!-- SLDPTH thickness of each soil layer (m, same as DZS) +!-- TMN soil temperature at lower boundary (K) +!-- SMCWLT wilting point (volumetric) +!-- SMCDRY dry soil moisture threshold where direct evap from +! top soil layer ends (volumetric) +!-- SMCREF soil moisture threshold below which transpiration begins to +! stress (volumetric) +!-- SMCMAX porosity, i.e. saturated value of soil moisture (volumetric) +!-- NROOT number of root layers, a function of veg type, determined +! in subroutine redprm. +!-- SMSTAV Soil moisture availability for evapotranspiration ( +! fraction between SMCWLT and SMCMXA) +!-- SMSTOT Total soil moisture content frozen+unfrozen) in the soil column (mm) +! --- snow variables +!-- SNOWC fraction snow coverage (0-1.0) +! --- vegetation variables +!-- SNOALB upper bound on maximum albedo over deep snow +!-- SHDMIN minimum areal fractional coverage of annual green vegetation +!-- SHDMAX maximum areal fractional coverage of annual green vegetation +!-- XLAI leaf area index (dimensionless) +!-- Z0BRD Background fixed roughness length (M) +!-- Z0 Background vroughness length (M) as function +!-- ZNT Time varying roughness length (M) as function +!-- ALBD(IVGTPK,ISN) background albedo reading from a table +! --- LSM output +!-- HFX upward heat flux at the surface (W/m^2) +!-- QFX upward moisture flux at the surface (kg/m^2/s) +!-- LH upward moisture flux at the surface (W m-2) +!-- GRDFLX(I,J) ground heat flux (W m-2) +!-- FDOWN radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +!---------------------------------------------------------------------------- +!-- EC canopy water evaporation ((W m-2) +!-- EDIR direct soil evaporation (W m-2) +!-- ET plant transpiration from a particular root layer (W m-2) +!-- ETT total plant transpiration (W m-2) +!-- ESNOW sublimation from (or deposition to if <0) snowpack (W m-2) +!-- DRIP through-fall of precip and/or dew in excess of canopy +! water-holding capacity (m) +!-- DEW dewfall (or frostfall for t<273.15) (M) +!-- SMAV Soil Moisture Availability for each layer, as a fraction +! between SMCWLT and SMCMAX (dimensionless fraction) +! ---------------------------------------------------------------------- +!-- BETA ratio of actual/potential evap (dimensionless) +!-- ETP potential evaporation (W m-2) +! ---------------------------------------------------------------------- +!-- FLX1 precip-snow sfc (W m-2) +!-- FLX2 freezing rain latent heat flux (W m-2) +!-- FLX3 phase-change heat flux from snowmelt (W m-2) +! ---------------------------------------------------------------------- +!-- ACSNOM snow melt (mm) (water equivalent) +!-- ACSNOW accumulated snow fall (mm) (water equivalent) +!-- SNOPCX snow phase change heat flux (W/m^2) +!-- POTEVP accumulated potential evaporation (m) +!-- RIB Documentation needed!!! +! ---------------------------------------------------------------------- +!-- RUNOFF1 surface runoff (m s-1), not infiltrating the surface +!-- RUNOFF2 subsurface runoff (m s-1), drainage out bottom of last +! soil layer (baseflow) +! important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3 +!-- RUNOFF3 numerical trunctation in excess of porosity (smcmax) +! for a given soil layer at the end of a time step (m s-1). +!SFCRUNOFF Surface Runoff (mm) +!UDRUNOFF Total Underground Runoff (mm), which is the sum of RUNOFF2 and RUNOFF3 +! ---------------------------------------------------------------------- +!-- RC canopy resistance (s m-1) +!-- PC plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp +!-- RSMIN minimum canopy resistance (s m-1) +!-- RCS incoming solar rc factor (dimensionless) +!-- RCT air temperature rc factor (dimensionless) +!-- RCQ atmos vapor pressure deficit rc factor (dimensionless) +!-- RCSOIL soil moisture rc factor (dimensionless) + +!-- EMISS surface emissivity (between 0 and 1) +!-- EMBCK Background surface emissivity (between 0 and 1) + +!-- ROVCP R/CP +! (R_d/R_v) (dimensionless) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!-- SR fraction of frozen precip (0.0 to 1.0) +!---------------------------------------------------------------- + +! IN only + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: sf_urban_physics !urban + INTEGER, INTENT(IN ) :: isurban + INTEGER, INTENT(IN ) :: isice + INTEGER, INTENT(IN ) :: julian,julyr + +!added by Wei Yu for routing +#ifdef WRF_HYDRO + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain + real :: etpnd1 +#endif +!end added + +! new local vars for hydro + REAL :: etpnd1_hydro,sfcheadrt_hydro,infxsrt_hydro + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: TMN, & + XLAND, & + XICE, & + VEGFRA, & + SHDMIN, & + SHDMAX, & + SNOALB, & + GSW, & + SWDOWN, & !added 10 jan 2007 + GLW, & + RAINBL, & + SR + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ALBBCK, & + Z0, & + EMBCK ! danli mosaic + + CHARACTER(LEN=*), INTENT(IN ) :: MMINLU + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: QV3D, & + p8w3D, & + DZ8W, & + T3D + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: QGH, & + CPM + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: ISLTYP + + INTEGER, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT ) :: IVGTYP ! for mosaic danli + + INTEGER, INTENT(IN) :: num_soil_layers,ITIMESTEP + + REAL, INTENT(IN ) :: DT,ROVCP + + REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::DZS + +! IN and OUT + + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & + INTENT(INOUT) :: SMOIS, & ! total soil moisture + SH2O, & ! new soil liquid + TSLB ! TSLB STEMP + + REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & + INTENT(OUT) :: SMCREL + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: TSK, & !was TGB (temperature) + HFX, & + QFX, & + LH, & + GRDFLX, & + QSFC,& + CQS2,& + CHS, & + CHS2,& + SNOW, & + SNOWC, & + SNOWH, & !new + CANWAT, & + SMSTAV, & + SMSTOT, & + SFCRUNOFF, & + UDRUNOFF, & + ACSNOM, & + ACSNOW, & + SNOTIME, & + SNOPCX, & + EMISS, & + RIB, & + POTEVP, & + ALBEDO, & + ZNT + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: NOAHRES + INTEGER, INTENT(IN) :: OPT_THCND + +! Noah UA changes + LOGICAL, INTENT(IN) :: UA_PHYS + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: FLX4_2D,FVB_2D,FBUR_2D,FGSN_2D + REAL :: FLX4,FVB,FBUR,FGSN + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(OUT) :: CHKLOWQ + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: QZ0 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: RC2, XLAI2 + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF +! Local variables (moved here from driver to make routine thread safe, 20031007 jm) + + REAL, DIMENSION(1:num_soil_layers) :: ET + + REAL, DIMENSION(1:num_soil_layers) :: SMAV + + REAL :: BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT, & + FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI, & +! RCS,RCT,RCQ,RCSOIL + RCS,RCT,RCQ,RCSOIL,FFROZP + + LOGICAL, INTENT(IN ) :: myj,frpcpn + +! DECLARATIONS - LOGICAL +! ---------------------------------------------------------------------- + LOGICAL, PARAMETER :: LOCAL=.false. + LOGICAL :: FRZGRA, SNOWNG + + LOGICAL :: IPRINT + +! ---------------------------------------------------------------------- +! DECLARATIONS - INTEGER +! ---------------------------------------------------------------------- + INTEGER :: I,J, ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP + INTEGER :: NROOT + INTEGER :: KZ ,K + INTEGER :: NS +! ---------------------------------------------------------------------- +! DECLARATIONS - REAL +! ---------------------------------------------------------------------- + + REAL :: SHMIN,SHMAX,DQSDT2,LWDN,PRCP,PRCPRAIN, & + Q2SAT,Q2SATI,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1, & + SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, & + EMBRD, & + Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT,SOLNET,E2SAT,SFCTSNO, & +! mek, WRF testing, expanded diagnostics + SOLUP,LWUP,RNET,RES,Q1SFC,TAIRV,SATFLG +! MEK MAY 2007 + REAL :: FDTLIW +! MEK JUL2007 for pot. evap. + REAL :: RIBB + REAL :: FDTW + + REAL :: EMISSI + + REAL :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2 + + REAL :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1 + REAL :: SNOTIME1 ! LSTSNW1 INITIAL NUMBER OF TIMESTEPS SINCE LAST SNOWFALL + + REAL :: DUMMY,Z0BRD +! + REAL :: COSZ, SOLARDIRECT +! + REAL, DIMENSION(1:num_soil_layers):: SLDPTH, STC,SMC,SWC +! + REAL, DIMENSION(1:num_soil_layers) :: ZSOIL, RTDIS + REAL, PARAMETER :: TRESH=.95E0, A2=17.67,A3=273.15,A4=29.65, & + T0=273.16E0, ELWV=2.50E6, A23M4=A2*(A3-A4) +! MEK MAY 2007 + REAL, PARAMETER :: ROW=1.E3,ELIW=XLF,ROWLIW=ROW*ELIW + +! ---------------------------------------------------------------------- +! DECLARATIONS START - urban +! ---------------------------------------------------------------------- + +! input variables surface_driver --> lsm + INTEGER, INTENT(IN) :: num_roof_layers + INTEGER, INTENT(IN) :: num_wall_layers + INTEGER, INTENT(IN) :: num_road_layers + REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR + REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB + REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG + REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: U_PHY + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: V_PHY + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: TH_PHY + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: P_PHY + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST + + LOGICAL, intent(in) :: rdlai2d + LOGICAL, intent(in) :: USEMONALB + +! input variables lsm --> urban + INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3] + REAL :: TA_URB ! potential temp at 1st atmospheric level [K] + REAL :: QA_URB ! mixing ratio at 1st atmospheric level [kg/kg] + REAL :: UA_URB ! wind speed at 1st atmospheric level [m/s] + REAL :: U1_URB ! u at 1st atmospheric level [m/s] + REAL :: V1_URB ! v at 1st atmospheric level [m/s] + REAL :: SSG_URB ! downward total short wave radiation [W/m/m] + REAL :: LLG_URB ! downward long wave radiation [W/m/m] + REAL :: RAIN_URB ! precipitation [mm/h] + REAL :: RHOO_URB ! air density [kg/m^3] + REAL :: ZA_URB ! first atmospheric level [m] + REAL :: DELT_URB ! time step [s] + REAL :: SSGD_URB ! downward direct short wave radiation [W/m/m] + REAL :: SSGQ_URB ! downward diffuse short wave radiation [W/m/m] + REAL :: XLAT_URB ! latitude [deg] + REAL :: COSZ_URB ! cosz + REAL :: OMG_URB ! hour angle + REAL :: ZNT_URB ! roughness length [m] + REAL :: TR_URB + REAL :: TB_URB + REAL :: TG_URB + REAL :: TC_URB + REAL :: QC_URB + REAL :: UC_URB + REAL :: XXXR_URB + REAL :: XXXB_URB + REAL :: XXXG_URB + REAL :: XXXC_URB + REAL, DIMENSION(1:num_roof_layers) :: TRL_URB ! roof layer temp [K] + REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] + REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] + LOGICAL :: LSOLAR_URB + +!===Yang,2014/10/08,hydrological variable for single layer UCM=== + INTEGER :: jmonth, jday, tloc + INTEGER :: IRIOPTION, USOIL, DSOIL + REAL :: AOASIS, OMG + REAL :: DRELR_URB + REAL :: DRELB_URB + REAL :: DRELG_URB + REAL :: FLXHUMR_URB + REAL :: FLXHUMB_URB + REAL :: FLXHUMG_URB + REAL :: CMCR_URB + REAL :: TGR_URB + REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture + REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D + +! state variable surface_driver <--> lsm <--> urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D +! + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D + + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D + +! output variable lsm --> surface_driver + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D +! + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D +! + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D ! change this to inout, danli mosaic + INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D + +! output variables urban --> lsm + REAL :: TS_URB ! surface radiative temperature [K] + REAL :: QS_URB ! surface humidity [-] + REAL :: SH_URB ! sensible heat flux [W/m/m] + REAL :: LH_URB ! latent heat flux [W/m/m] + REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic [kg/m/m/s] + REAL :: SW_URB ! upward short wave radiation flux [W/m/m] + REAL :: ALB_URB ! time-varying albedo [fraction] + REAL :: LW_URB ! upward long wave radiation flux [W/m/m] + REAL :: G_URB ! heat flux into the ground [W/m/m] + REAL :: RN_URB ! net radiation [W/m/m] + REAL :: PSIM_URB ! shear f for momentum [-] + REAL :: PSIH_URB ! shear f for heat [-] + REAL :: GZ1OZ0_URB ! shear f for heat [-] + REAL :: U10_URB ! wind u component at 10 m [m/s] + REAL :: V10_URB ! wind v component at 10 m [m/s] + REAL :: TH2_URB ! potential temperature at 2 m [K] + REAL :: Q2_URB ! humidity at 2 m [-] + REAL :: CHS_URB + REAL :: CHS2_URB + REAL :: UST_URB +! NUDAPT Parameters urban --> lam + REAL :: mh_urb + REAL :: stdh_urb + REAL :: lp_urb + REAL :: hgt_urb + REAL, DIMENSION(4) :: lf_urb +! Variables for multi-layer UCM (Martilli et al. 2002) + REAL, OPTIONAL, INTENT(IN ) :: GMT + INTEGER, OPTIONAL, INTENT(IN ) :: JULDAY + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) ::XLAT, XLONG + INTEGER, INTENT(IN ) :: num_urban_ndm + INTEGER, INTENT(IN ) :: urban_map_zrd + INTEGER, INTENT(IN ) :: urban_map_zwd + INTEGER, INTENT(IN ) :: urban_map_gd + INTEGER, INTENT(IN ) :: urban_map_zd + INTEGER, INTENT(IN ) :: urban_map_zdf + INTEGER, INTENT(IN ) :: urban_map_bd + INTEGER, INTENT(IN ) :: urban_map_wd + INTEGER, INTENT(IN ) :: urban_map_gbd + INTEGER, INTENT(IN ) :: urban_map_fbd + INTEGER, INTENT(IN ) :: urban_map_zgrd + INTEGER, INTENT(IN ) :: NUM_URBAN_HI + INTEGER, INTENT(IN ) :: use_wudapt_lcz + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: tsk_rural_bep + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zrd, jms:jme ), INTENT(INOUT) :: trb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw1_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zwd, jms:jme ), INTENT(INOUT) :: tw2_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gd , jms:jme ), INTENT(INOUT) :: tgb_urb4d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: tlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_bd , jms:jme ), INTENT(INOUT) :: qlev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw1lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: tw2lev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_gbd, jms:jme ), INTENT(INOUT) :: tglev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_fbd, jms:jme ), INTENT(INOUT) :: tflev_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_wd , jms:jme ), INTENT(INOUT) :: sfwin2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw1_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zd , jms:jme ), INTENT(INOUT) :: sfw2_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: sfr_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: sfg_urb3d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ep_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ), INTENT(INOUT) :: t_pv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: trv_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme ),INTENT(INOUT) :: qr_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: qgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime,jms:jme ), INTENT(INOUT) :: tgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: drain_urb4d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: draingr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: sfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfrv_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: dgr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: dg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: lfr_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: lfg_urb3d !GRZ + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: hgt_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: mh_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: stdh_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN) :: lf_urb2d + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep !Implicit momemtum component X-direction + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep !Implicit momemtum component Y-direction + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep !Implicit component pot. temperature + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep !Implicit momemtum component X-direction + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep !Implicit component TKE + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep !Explicit momentum component X-direction + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep !Explicit momentum component Y-direction + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep !Explicit component pot. temperature + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep !Implicit momemtum component Y-direction + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep !Explicit component TKE + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep !Fraction air volume in grid cell + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep !Height above ground + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep !Fraction air at the face of grid cell + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep !Length scale + +! Local variables for multi-layer UCM (Martilli et al. 2002) + REAL, DIMENSION( its:ite, jts:jte ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL ! ,RN_RURAL + REAL, DIMENSION( its:ite, jts:jte ) :: QFX_RURAL ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL + REAL, DIMENSION( its:ite, jts:jte ) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL +! REAL, DIMENSION( ims:ime, jms:jme ) :: QSFC_URB + REAL, DIMENSION( its:ite, jts:jte ) :: HFX_URB,UMOM_URB,VMOM_URB + REAL, DIMENSION( its:ite, jts:jte ) :: QFX_URB +! REAL, DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST + REAL, DIMENSION(its:ite,jts:jte) ::EMISS_URB + REAL, DIMENSION(its:ite,jts:jte) :: RL_UP_URB + REAL, DIMENSION(its:ite,jts:jte) ::RS_ABS_URB + REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB + REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM + REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB + REAL :: frc_urb,lb_urb + REAL :: check +! ---------------------------------------------------------------------- +! DECLARATIONS END - urban +! ---------------------------------------------------------------------- +!------------------------------------------------- +! Noah-mosaic related variables are added to declaration (danli) +!------------------------------------------------- + + INTEGER, INTENT(IN) :: sf_surface_mosaic + INTEGER, INTENT(IN) :: mosaic_cat, NLCAT + REAL, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(IN) :: landusef + REAL, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) ::landusef2 + INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) :: mosaic_cat_index + + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: & + TSK_mosaic, QSFC_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: & + ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic, & + HFX_mosaic,QFX_mosaic, LH_mosaic, GRDFLX_mosaic,SNOTIME_mosaic + REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT):: & + TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT):: LAI_mosaic, RC_mosaic + + REAL, DIMENSION( ims:ime, jms:jme ) :: TSK_mosaic_avg, QSFC_mosaic_avg, CANWAT_mosaic_avg,SNOW_mosaic_avg,SNOWH_mosaic_avg, & + SNOWC_mosaic_avg, HFX_mosaic_avg, QFX_mosaic_avg, LH_mosaic_avg, GRDFLX_mosaic_avg, & + ALBEDO_mosaic_avg, ALBBCK_mosaic_avg, EMISS_mosaic_avg, EMBCK_mosaic_avg, & + ZNT_mosaic_avg, Z0_mosaic_avg, LAI_mosaic_avg, RC_mosaic_avg, SNOTIME_mosaic_avg, & + FAREA_mosaic_avg + REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ) :: & + TSLB_mosaic_avg,SMOIS_mosaic_avg,SH2O_mosaic_avg + + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: & + TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic, UC_URB2D_mosaic, & + SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic + + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic + + INTEGER, DIMENSION( ims:ime, jms:jme ) :: IVGTYP_dominant + INTEGER :: mosaic_i, URBAN_METHOD, zo_avg_option + REAL :: FAREA + LOGICAL :: IPRINT_mosaic, Noah_call +!------------------------------------------------- +! Noah-mosaic related variables declaration end (danli) +!------------------------------------------------- + + REAL, PARAMETER :: CAPA=R_D/CP + REAL :: APELM,APES,SFCTH2,PSFC + real, intent(in) :: xice_threshold + character(len=80) :: message_text +! +! FASDAS: it doesn't work for mosaic, but we need the variables to call sflx +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM + INTEGER, INTENT(IN ) :: fasdas + REAL :: XSDA_HFX, XSDA_QFX, XQNORM + REAL :: HFX_PHY, QFX_PHY + REAL :: DZQ + REAL :: HCPCT_FASDAS + REAL,OPTIONAL,DIMENSION( ims:ime, jms:jme ) :: IRR_CHAN + REAL :: IRRIGATION_CHANNEL + IRRIGATION_CHANNEL=0.0 + HFX_PHY = 0.0 ! initialize + QFX_PHY = 0.0 + XQNORM = 0.0 + XSDA_HFX = 0.0 + XSDA_QFX = 0.0 +! +! END FASDAS +! +! MEK MAY 2007 + FDTLIW=DT/ROWLIW +! MEK JUL2007 + FDTW=DT/(XLV*RHOWATER) +! debug printout + IPRINT=.false. + IPRINT_mosaic=.false. + +! SLOPETYP=2 + SLOPETYP=1 +! SHDMIN=0.00 + + NSOIL=num_soil_layers + + DO NS=1,NSOIL + SLDPTH(NS)=DZS(NS) + ENDDO + + JLOOP : DO J=jts,jte + + IF(ITIMESTEP.EQ.1)THEN + DO 50 I=its,ite +!*** initialize soil conditions for IHOP 31 May case +! IF((XLAND(I,J)-1.5) < 0.)THEN +! if (I==108.and.j==85) then +! DO NS=1,NSOIL +! SMOIS(I,NS,J)=0.10 +! SH2O(I,NS,J)=0.10 +! enddo +! endif +! ENDIF + +!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS + IF((XLAND(I,J)-1.5).GE.0.)THEN +! check sea-ice point +#if 0 + IF( XICE(I,J).GE. XICE_THRESHOLD .and. IPRINT ) PRINT*, ' sea-ice at water point, I=',I,'J=',J +#endif +!*** Open Water Case + SMSTAV(I,J)=1.0 + SMSTOT(I,J)=1.0 + DO NS=1,NSOIL + SMOIS(I,NS,J)=1.0 + TSLB(I,NS,J)=273.16 !STEMP + SMCREL(I,NS,J)=1.0 + ENDDO + ELSE + IF ( XICE(I,J) .GE. XICE_THRESHOLD ) THEN +!*** SEA-ICE CASE + SMSTAV(I,J)=1.0 + SMSTOT(I,J)=1.0 + DO NS=1,NSOIL + SMOIS(I,NS,J)=1.0 + SMCREL(I,NS,J)=1.0 + ENDDO + ENDIF + ENDIF +! + 50 CONTINUE + ENDIF ! end of initialization over ocean + +!----------------------------------------------------------------------- + ILOOP : DO I=its,ite + +! initializing local variables + SOILW = 0. + FLX4 = 0. + FVB = 0. + FBUR = 0. + FGSN = 0. + + IF (((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN + + IVGTYP_dominant(I,J)=IVGTYP(I,J) ! save this + + ! INITIALIZE THE AREA-AVERAGED FLUXES + + TSK_mosaic_avg(i,j)= 0.0 ! from 3D to 2D + QSFC_mosaic_avg(i,j)= 0.0 + CANWAT_mosaic_avg(i,j)= 0.0 + SNOW_mosaic_avg(i,j)= 0.0 + SNOWH_mosaic_avg(i,j)= 0.0 + SNOWC_mosaic_avg(i,j)= 0.0 + + DO NS=1,NSOIL + + TSLB_mosaic_avg(i,NS,j)=0.0 + SMOIS_mosaic_avg(i,NS,j)=0.0 + SH2O_mosaic_avg(i,NS,j)=0.0 + + ENDDO + + HFX_mosaic_avg(i,j)= 0.0 + QFX_mosaic_avg(i,j)= 0.0 + LH_mosaic_avg(i,j)= 0.0 + GRDFLX_mosaic_avg(i,j)= 0.0 + ALBEDO_mosaic_avg(i,j)=0.0 + ALBBCK_mosaic_avg(i,j)=0.0 + EMISS_mosaic_avg(i,j)=0.0 + EMBCK_mosaic_avg(i,j)=0.0 + ZNT_mosaic_avg(i,j)=0.0 + Z0_mosaic_avg(i,j)=0.0 + LAI_mosaic_avg(i,j)=0.0 + RC_mosaic_avg(i,j)=0.0 + FAREA_mosaic_avg(i,j)=0.0 + + ! add a new loop for the mosaic_cat + + DO mosaic_i = mosaic_cat, 1, -1 + + ! if (mosaic_cat_index(I,mosaic_i,J) .EQ. 16 ) then + ! PRINT*, 'you still have water tiles at','i=',i,'j=',j, 'mosaic_i',mosaic_i + ! PRINT*, 'xland',xland(i,j),'xice',xice(i,j) + ! endif + + IVGTYP(I,J)=mosaic_cat_index(I,mosaic_i,J) ! replace it with the mosaic one + TSK(I,J)=TSK_mosaic(I,mosaic_i,J) ! from 3D to 2D + QSFC(i,j)=QSFC_mosaic(I,mosaic_i,J) + CANWAT(i,j)=CANWAT_mosaic(i,mosaic_i,j) + SNOW(i,j)=SNOW_mosaic(i,mosaic_i,j) + SNOWH(i,j)=SNOWH_mosaic(i,mosaic_i,j) + SNOWC(i,j)=SNOWC_mosaic(i,mosaic_i,j) + + ALBEDO(i,j) = ALBEDO_mosaic(i,mosaic_i,j) + ALBBCK(i,j)= ALBBCK_mosaic(i,mosaic_i,j) + EMISS(i,j)= EMISS_mosaic(i,mosaic_i,j) + EMBCK(i,j)= EMBCK_mosaic(i,mosaic_i,j) + ZNT(i,j)= ZNT_mosaic(i,mosaic_i,j) + Z0(i,j)= Z0_mosaic(i,mosaic_i,j) + + SNOTIME(i,j)= SNOTIME_mosaic(i,mosaic_i,j) + + DO NS=1,NSOIL + + TSLB(i,NS,j)=TSLB_mosaic(i,NSOIL*(mosaic_i-1)+NS,j) + SMOIS(i,NS,j)=SMOIS_mosaic(i,NSOIL*(mosaic_i-1)+NS,j) + SH2O(i,NS,j)=SH2O_mosaic(i,NSOIL*(mosaic_i-1)+NS,j) + + ENDDO + + IF(IPRINT_mosaic) THEN + + print*, 'BEFORE SFLX, in Noahdrv.F' + print*, 'mosaic_cat', mosaic_cat, 'IVGTYP',IVGTYP(i,j), 'TSK',TSK(i,j),'HFX',HFX(i,j), 'QSFC', QSFC(i,j), & + 'CANWAT', CANWAT(i,j), 'SNOW',SNOW(i,j), 'ALBEDO',ALBEDO(i,j), 'TSLB',TSLB(i,1,j),'CHS',CHS(i,j),'ZNT',ZNT(i,j) + + ENDIF + + !----------------------------------------------------------------------- + ! insert the NOAH model here for the non-urban one and the urban one DANLI + !----------------------------------------------------------------------- + + ! surface pressure + PSFC=P8w3D(i,1,j) + ! pressure in middle of lowest layer + SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5 + ! convert from mixing ratio to specific humidity + Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j)) + ! + ! Q2SAT=QGH(I,j) + Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity + ! add check on myj=.true. + ! IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN + IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN + SATFLG=0. + CHKLOWQ(I,J)=0. + ELSE + SATFLG=1.0 + CHKLOWQ(I,J)=1. + ENDIF + + SFCTMP=T3D(i,1,j) + ZLVL=0.5*DZ8W(i,1,j) + + ! TH2=SFCTMP+(0.0097545*ZLVL) + ! calculate SFCTH2 via Exner function vs lapse-rate (above) + APES=(1.E5/PSFC)**CAPA + APELM=(1.E5/SFCPRS)**CAPA + SFCTH2=SFCTMP*APELM + TH2=SFCTH2/APES + ! + EMISSI = EMISS(I,J) + LWDN=GLW(I,J)*EMISSI + ! SOLDN is total incoming solar + SOLDN=SWDOWN(I,J) + ! GSW is net downward solar + ! SOLNET=GSW(I,J) + ! use mid-day albedo to determine net downward solar (no solar zenith angle correction) + SOLNET=SOLDN*(1.-ALBEDO(I,J)) + PRCP=RAINBL(i,j)/DT + IF(PRESENT(IRR_CHAN)) THEN + IF(IRR_CHAN(i,j).NE.0) THEN + IRRIGATION_CHANNEL=IRR_CHAN(i,j)/DT + ELSE + IRRIGATION_CHANNEL=0. + END IF + ENDIF + VEGTYP=IVGTYP(I,J) + SOILTYP=ISLTYP(I,J) + SHDFAC=VEGFRA(I,J)/100. + T1=TSK(I,J) + CHK=CHS(I,J) + SHMIN=SHDMIN(I,J)/100. !NEW + SHMAX=SHDMAX(I,J)/100. !NEW + ! convert snow water equivalent from mm to meter + SNEQV=SNOW(I,J)*0.001 + ! snow depth in meters + SNOWHK=SNOWH(I,J) + SNCOVR=SNOWC(I,J) + + ! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1) + ! SR from e.g. Ferrier microphysics + ! otherwise define from 1st atmos level temperature + IF(FRPCPN) THEN + FFROZP=SR(I,J) + ELSE + IF (SFCTMP <= 273.15) THEN + FFROZP = 1.0 + ELSE + FFROZP = 0.0 + ENDIF + ENDIF + !*** + IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block + ! Open water points + TSK_RURAL(I,J)=TSK(I,J) + HFX_RURAL(I,J)=HFX(I,J) + QFX_RURAL(I,J)=QFX(I,J) + LH_RURAL(I,J)=LH(I,J) + EMISS_RURAL(I,J)=EMISS(I,J) + GRDFLX_RURAL(I,J)=GRDFLX(I,J) + ELSE + ! Land or sea-ice case + + IF (XICE(I,J) >= XICE_THRESHOLD) THEN + ! Sea-ice point + ICE = 1 + ELSE IF ( VEGTYP == ISICE ) THEN + ! Land-ice point + ICE = -1 + ELSE + ! Neither sea ice or land ice. + ICE=0 + ENDIF + DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2 + + IF(SNOW(I,J).GT.0.0)THEN + ! snow on surface (use ice saturation properties) + SFCTSNO=SFCTMP + E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO)) + Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT) + Q2SATI=Q2SATI/(1.0+Q2SATI) ! spec. hum. + IF (T1 .GT. 273.14) THEN + ! warm ground temps, weight the saturation between ice and water according to SNOWC + Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J) + DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J) + ELSE + ! cold ground temps, use ice saturation only + Q2SAT=Q2SATI + DQSDT2=Q2SATI*6174./(SFCTSNO**2) + ENDIF + ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero + IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + ENDIF + + ! Land-ice or land points use the usual deep-soil temperature. + TBOT=TMN(I,J) + + IF(VEGTYP.EQ.25) SHDFAC=0.0000 + IF(VEGTYP.EQ.26) SHDFAC=0.0000 + IF(VEGTYP.EQ.27) SHDFAC=0.0000 + IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN +#if 0 + IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' + IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F' +#endif + SOILTYP=7 + ENDIF + SNOALB1 = SNOALB(I,J) +! converts canwat in mm to CMC in meters + CMC=CANWAT(I,J)/1000. + + !------------------------------------------- + !*** convert snow depth from mm to meter + ! + ! IF(RDMAXALB) THEN + ! SNOALB=ALBMAX(I,J)*0.01 + ! ELSE + ! SNOALB=MAXALB(IVGTPK)*0.01 + ! ENDIF + + ! SNOALB1=0.80 + ! SHMIN=0.00 + ALBBRD=ALBBCK(I,J) + Z0BRD=Z0(I,J) + EMBRD=EMBCK(I,J) + SNOTIME1 = SNOTIME(I,J) + RIBB=RIB(I,J) + !FEI: temporaray arrays above need to be changed later by using SI + + DO NS=1,NSOIL + SMC(NS)=SMOIS(I,NS,J) + STC(NS)=TSLB(I,NS,J) !STEMP + SWC(NS)=SH2O(I,NS,J) + ENDDO + ! + if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN + SNOWHK= 5.*SNEQV + endif + ! + + !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as + ! the "NATURAL" category in the VEGPARM.TBL + + ! IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN + + ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + ! VEGTYP = NATURAL + ! SHDFAC = SHDTBL(NATURAL) + ! ALBEDOK =0.2 ! 0.2 + ! ALBBRD =0.2 !0.2 + ! EMISSI = 0.98 !for VEGTYP=5 + ! IF ( FRC_URB2D(I,J) < 0.99 ) THEN + ! if(sf_urban_physics.eq.1)then + ! T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) + ! elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then + ! r1= (tsk(i,j)**4.) + ! r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.) + ! r3= (1.-frc_urb2d(i,j)) + ! t1= ((r1-r2)/r3)**.25 + ! endif + ! ELSE + ! T1 = TSK(I,J) + ! ENDIF + ! ENDIF + ! ELSE + ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + ! VEGTYP = ISURBAN + ! ENDIF + ! ENDIF + + Noah_call=.TRUE. + + If ( SF_URBAN_PHYSICS == 0 ) THEN ! ONLY NOAH + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + Noah_call = .TRUE. + VEGTYP = ISURBAN + ENDIF + + ENDIF + + IF(SF_URBAN_PHYSICS == 1) THEN + + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + Noah_call = .TRUE. + VEGTYP = NATURAL + SHDFAC = SHDTBL(NATURAL) + ALBEDOK =0.2 ! 0.2 + ALBBRD =0.2 ! 0.2 + EMISSI = 0.98 ! for VEGTYP=5 + LWDN = GLW(I,J) * EMISSI + SOLNET = SOLDN * (1.0 - ALBEDOK) + + T1= TS_RUL2D_mosaic(I,mosaic_i,J) + + ENDIF + + ENDIF + +!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== + AOASIS = 1.0 + USOIL = 1 + DSOIL = 2 + IRIOPTION=IRI_SCHEME + OMG= OMG_URB2D(I,J) + tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24) + if (tloc.lt.0) tloc=tloc+24 + if (tloc==0) tloc=24 + CALL cal_mon_day(julian,julyr,jmonth,jday) + IF(SF_URBAN_PHYSICS == 1) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + AOASIS = oasis ! urban oasis effect + IF (IRIOPTION ==1) THEN + IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm + IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN + IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J)) + IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J)) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + IF(AOASIS > 1.0) THEN + CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + IF(IRIOPTION == 1) THEN + CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + ENDIF + + IF( SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN +! print*, 'MOSAIC is not designed to work with SF_URBAN_PHYSICS=2 or SF_URBAN_PHYSICS=3' + ENDIF + + IF (Noah_call) THEN +#if 0 + IF(IPRINT) THEN + ! + print*, 'BEFORE SFLX, in Noahlsm_driver' + print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, & + 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',& + LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, & + 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, & + 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,& + 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,& + 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',& + TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',& + STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,& + 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, & + 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, & + 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,& + 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,& + 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,& + 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, & + 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, & + 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, & + 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,& + 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT + endif +#endif + + IF (rdlai2d) THEN + IF (SHDFAC > 0.0 .AND. LAI(I,J) <= 0.0) LAI(I,J) = 0.01 + xlai = lai(i,j) + endif + + IF ( ICE == 1 ) THEN + + ! Sea-ice case + + DO NS = 1, NSOIL + SH2O(I,NS,J) = 1.0 + ENDDO + LAI(I,J) = 0.01 + + CYCLE ILOOP + + ELSEIF (ICE == 0) THEN + + ! Non-glacial land + + CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & +! WRF_HYDRO vars + sfcheadrt_hydro, & !I + INFXSRT_hydro,ETPND1_hydro & !O + ,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars + ,IRRIGATION_CHANNEL ) + +#ifdef WRF_HYDRO + soldrain(i,j) = RUNOFF2*DT*1000.0 + sfcheadrt(i,j) = sfcheadrt_hydro + infxsrt(i,j) = INFXSRT_hydro + etpnd1 = etpnd1_hydro +#endif + ELSEIF (ICE == -1) THEN + + ! + ! Set values that the LSM is expected to update, + ! but don't get updated for glacial points. + ! + SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero + XLAI = 0.01 ! KWM Should this be Zero over land ice? Does this value matter? + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + DO NS = 1, NSOIL + SWC(NS) = 1.0 + SMC(NS) = 1.0 + SMAV(NS) = 1.0 + ENDDO + CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C + & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F + & TH2,Q2SAT,DQSDT2, & !I + & ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + & T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK, & !H + & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O + & ESNOW,DEW, & !O + & ETP,SSOIL, & !O + & FLX1,FLX2,FLX3, & !O + & SNOMLT,SNCOVR, & !O + & RUNOFF1, & !O + & Q1, & !D + & SNOTIME1, & + & RIBB) + + ENDIF + lai(i,j) = xlai +#if 0 + IF(IPRINT) THEN + + print*, 'AFTER SFLX, in Noahlsm_driver' + print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, & + 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',& + LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, & + 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, & + 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,& + 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,& + 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',& + TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',& + STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,& + 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, & + 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, & + 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,& + 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,& + 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,& + 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, & + 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, & + 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, & + 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,& + 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT + endif +#endif + + !*** UPDATE STATE VARIABLES + CANWAT(I,J)=CMC*1000. + SNOW(I,J)=SNEQV*1000. + ! SNOWH(I,J)=SNOWHK*1000. + SNOWH(I,J)=SNOWHK ! SNOWHK in meters + ALBEDO(I,J)=ALBEDOK + ALB_RURAL(I,J)=ALBEDOK + ALBBCK(I,J)=ALBBRD + Z0(I,J)=Z0BRD + EMISS(I,J) = EMISSI + EMISS_RURAL(I,J) = EMISSI + ! Noah: activate time-varying roughness length (V3.3 Feb 2011) + ZNT(I,J)=Z0K + TSK(I,J)=T1 + TSK_RURAL(I,J)=T1 + HFX(I,J)=SHEAT + HFX_RURAL(I,J)=SHEAT + ! MEk Jul07 add potential evap accum + POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW + QFX(I,J)=ETA_KINEMATIC + QFX_RURAL(I,J)=ETA_KINEMATIC + +#ifdef WRF_HYDRO + !added by Wei Yu + ! QFX(I,J) = QFX(I,J) + ETPND1 + ! ETA = ETA + ETPND1/2.501E6*dt + !end added by Wei Yu +#endif + + LH(I,J)=ETA + LH_RURAL(I,J)=ETA + GRDFLX(I,J)=SSOIL + GRDFLX_RURAL(I,J)=SSOIL + SNOWC(I,J)=SNCOVR + CHS2(I,J)=CQS2(I,J) + SNOTIME(I,J) = SNOTIME1 + ! prevent diagnostic ground q (q1) from being greater than qsat(tsk) + ! as happens over snow cover where the cqs2 value also becomes irrelevant + ! by setting cqs2=chs in this situation the 2m q should become just qv(k=1) + IF (Q1 .GT. QSFC(I,J)) THEN + CQS2(I,J) = CHS(I,J) + ENDIF + ! QSFC(I,J)=Q1 + ! Convert QSFC back to mixing ratio + QSFC(I,J)= Q1/(1.0-Q1) + ! + ! QSFC_RURAL(I,J)= Q1/(1.0-Q1) + ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002) + + DO 81 NS=1,NSOIL + SMOIS(I,NS,J)=SMC(NS) + TSLB(I,NS,J)=STC(NS) ! STEMP + SH2O(I,NS,J)=SWC(NS) + 81 CONTINUE + ! ENDIF + + FLX4_2D(I,J) = FLX4 + FVB_2D(I,J) = FVB + FBUR_2D(I,J) = FBUR + FGSN_2D(I,J) = FGSN + + ! + ! Residual of surface energy balance equation terms + ! + + IF ( UA_PHYS ) THEN + noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta & + - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4 + + ELSE + noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta & + - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 + ENDIF + + ENDIF !ENDIF FOR Noah_call + + IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block + !-------------------------------------- + ! URBAN CANOPY MODEL START - urban + !-------------------------------------- + ! Input variables lsm --> urban + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + ! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) + ! this need to be changed in the mosaic danli + IF (use_wudapt_lcz == 1) THEN + IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=5 + IF(IVGTYP(I,J)==LCZ_1) UTYPE_URB=1 + IF(IVGTYP(I,J)==LCZ_2) UTYPE_URB=2 + IF(IVGTYP(I,J)==LCZ_3) UTYPE_URB=3 + IF(IVGTYP(I,J)==LCZ_4) UTYPE_URB=4 + IF(IVGTYP(I,J)==LCZ_5) UTYPE_URB=5 + IF(IVGTYP(I,J)==LCZ_6) UTYPE_URB=6 + IF(IVGTYP(I,J)==LCZ_7) UTYPE_URB=7 + IF(IVGTYP(I,J)==LCZ_8) UTYPE_URB=8 + IF(IVGTYP(I,J)==LCZ_9) UTYPE_URB=9 + IF(IVGTYP(I,J)==LCZ_10) UTYPE_URB=10 + IF(IVGTYP(I,J)==LCZ_11) UTYPE_URB=11 + + + IF(UTYPE_URB==1) FRC_URB2D(I,J)=1. + IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.99 + IF(UTYPE_URB==3) FRC_URB2D(I,J)=1.00 + IF(UTYPE_URB==4) FRC_URB2D(I,J)=0.65 + IF(UTYPE_URB==5) FRC_URB2D(I,J)=0.7 + IF(UTYPE_URB==6) FRC_URB2D(I,J)=0.65 + IF(UTYPE_URB==7) FRC_URB2D(I,J)=0.3 + IF(UTYPE_URB==8) FRC_URB2D(I,J)=0.85 + IF(UTYPE_URB==9) FRC_URB2D(I,J)=0.3 + IF(UTYPE_URB==10) FRC_URB2D(I,J)=0.55 + IF(UTYPE_URB==11) FRC_URB2D(I,J)=1. + ELSE + IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=2 + IF(IVGTYP(I,J)==LCZ_1) UTYPE_URB=1 ! LOW_DENSITY_RESIDENTIAL + IF(IVGTYP(I,J)==LCZ_2) UTYPE_URB=2 ! HIGH_DENSITY_RESIDENTIAL + IF(IVGTYP(I,J)==LCZ_3) UTYPE_URB=3 ! HIGH_INTENSITY_INDUSTRIAL + + IF(UTYPE_URB==1) FRC_URB2D(I,J)=0.5 + IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.9 + IF(UTYPE_URB==3) FRC_URB2D(I,J)=0.95 + END IF + + TA_URB = SFCTMP ! [K] + QA_URB = Q2K ! [kg/kg] + UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.) + U1_URB = U_PHY(I,1,J) + V1_URB = V_PHY(I,1,J) + IF(UA_URB < 1.) UA_URB=1. ! [m/s] + SSG_URB = SOLDN ! [W/m/m] + SSGD_URB = 0.8*SOLDN ! [W/m/m] + SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] + LLG_URB = GLW(I,J) ! [W/m/m] + RAIN_URB = RAINBL(I,J) / DT * 3600.0 ! [mm/hr] + RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] + ZA_URB = ZLVL ! [m] + DELT_URB = DT ! [sec] + XLAT_URB = XLAT_URB2D(I,J) ! [deg] + COSZ_URB = COSZ_URB2D(I,J) ! + OMG_URB = OMG_URB2D(I,J) ! + ZNT_URB = ZNT(I,J) + + LSOLAR_URB = .FALSE. + + ! mosaic 3D to 2D + + TR_URB2D(I,J)=TR_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + TB_URB2D(I,J)=TB_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + TG_URB2D(I,J)=TG_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + TC_URB2D(I,J)=TC_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + QC_URB2D(I,J)=QC_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + UC_URB2D(I,J)=UC_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + TS_URB2D(I,J)=TS_URB2D_mosaic(I,mosaic_i,J) ! replace it with the mosaic one + + DO K = 1,num_roof_layers + TRL_URB3D(I,K,J) = TRL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J) + END DO + DO K = 1,num_wall_layers + TBL_URB3D(I,K,J) = TBL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J) + END DO + DO K = 1,num_road_layers + TGL_URB3D(I,K,J) = TGL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J) + END DO + + ! mosaic 2D to 1D + + TR_URB = TR_URB2D(I,J) + TB_URB = TB_URB2D(I,J) + TG_URB = TG_URB2D(I,J) + TC_URB = TC_URB2D(I,J) + QC_URB = QC_URB2D(I,J) + UC_URB = UC_URB2D(I,J) + + DO K = 1,num_roof_layers + TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) + END DO + DO K = 1,num_wall_layers + TBL_URB(K) = TBL_URB3D(I,K,J) + END DO + DO K = 1,num_road_layers + TGL_URB(K) = TGL_URB3D(I,K,J) + END DO + + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) + + XXXR_URB = XXXR_URB2D(I,J) + XXXB_URB = XXXB_URB2D(I,J) + XXXG_URB = XXXG_URB2D(I,J) + XXXC_URB = XXXC_URB2D(I,J) + ! + ! Limits to avoid dividing by small number + if (CHS(I,J) < 1.0E-02) then + CHS(I,J) = 1.0E-02 + endif + if (CHS2(I,J) < 1.0E-02) then + CHS2(I,J) = 1.0E-02 + endif + if (CQS2(I,J) < 1.0E-02) then + CQS2(I,J) = 1.0E-02 + endif + ! + CHS_URB = CHS(I,J) + CHS2_URB = CHS2(I,J) + IF (PRESENT(CMR_SFCDIF)) THEN + CMR_URB = CMR_SFCDIF(I,J) + CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) + CMC_URB = CMC_SFCDIF(I,J) + CHC_URB = CHC_SFCDIF(I,J) + ENDIF + + ! NUDAPT for SLUCM + mh_urb = mh_urb2d(I,J) + stdh_urb = stdh_urb2d(I,J) + lp_urb = lp_urb2d(I,J) + hgt_urb = hgt_urb2d(I,J) + lf_urb = 0.0 + DO K = 1,4 + lf_urb(K)=lf_urb2d(I,K,J) + ENDDO + frc_urb = frc_urb2d(I,J) + lb_urb = lb_urb2d(I,J) + check = 0 + if (I.eq.73.and.J.eq.125)THEN + check = 1 + end if + ! + ! Call urban + CALL cal_mon_day(julian,julyr,jmonth,jday) + CALL urban(LSOLAR_URB, & ! I + num_roof_layers,num_wall_layers,num_road_layers, & ! C + DZR,DZB,DZG, & ! C + UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I + SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I + ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I + XLAT_URB,DELT_URB,ZNT_URB, & ! I + CHS_URB, CHS2_URB, & ! I + TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H + TRL_URB,TBL_URB,TGL_URB, & ! H + XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H + TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O + SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O + GZ1OZ0_URB, & !O + CMR_URB, CHR_URB, CMC_URB, CHC_URB, & + U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O + UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) + +#if 0 + IF(IPRINT) THEN + + print*, 'AFTER CALL URBAN' + print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', & + num_wall_layers, & + 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', & + TA_URB, & + 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', & + V1_URB, & + 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, & + 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, & + 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,& + 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, & + 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',& + TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, & + 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, & + 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,& + 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', & + LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,& + 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', & + RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, & + 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, & + 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB + endif +#endif + + TS_URB2D(I,J) = TS_URB + + ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-] + HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m] + QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB & + + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s] + LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m] + GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m] + TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K] + Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-] + ! Convert QSFC back to mixing ratio + QSFC(I,J)= Q1/(1.0-Q1) + UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J) ![m/s] + ZNT(I,J)= EXP(FRC_URB2D(I,J)*ALOG(ZNT_URB)+(1-FRC_URB2D(I,J))* ALOG(ZNT(I,J))) ! ADD BY DAN + +#if 0 + IF(IPRINT)THEN + + print*, ' FRC_URB2D', FRC_URB2D, & + 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, & + 'ALBEDO(I,J)', ALBEDO(I,J), & + 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), & + 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', & + ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), & + 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), & + 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),& + 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), & + 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J) + endif +#endif + + ! Renew Urban State Varialbes + + TR_URB2D(I,J) = TR_URB + TB_URB2D(I,J) = TB_URB + TG_URB2D(I,J) = TG_URB + TC_URB2D(I,J) = TC_URB + QC_URB2D(I,J) = QC_URB + UC_URB2D(I,J) = UC_URB + + DO K = 1,num_roof_layers + TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) + END DO + DO K = 1,num_wall_layers + TBL_URB3D(I,K,J) = TBL_URB(K) + END DO + DO K = 1,num_road_layers + TGL_URB3D(I,K,J) = TGL_URB(K) + END DO + + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + + XXXR_URB2D(I,J) = XXXR_URB + XXXB_URB2D(I,J) = XXXB_URB + XXXG_URB2D(I,J) = XXXG_URB + XXXC_URB2D(I,J) = XXXC_URB + + SH_URB2D(I,J) = SH_URB + LH_URB2D(I,J) = LH_URB + G_URB2D(I,J) = G_URB + RN_URB2D(I,J) = RN_URB + PSIM_URB2D(I,J) = PSIM_URB + PSIH_URB2D(I,J) = PSIH_URB + GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB + U10_URB2D(I,J) = U10_URB + V10_URB2D(I,J) = V10_URB + TH2_URB2D(I,J) = TH2_URB + Q2_URB2D(I,J) = Q2_URB + UST_URB2D(I,J) = UST_URB + AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) + IF (PRESENT(CMR_SFCDIF)) THEN + CMR_SFCDIF(I,J) = CMR_URB + CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB + CMC_SFCDIF(I,J) = CMC_URB + CHC_SFCDIF(I,J) = CHC_URB + ENDIF + + ! 2D to 3D mosaic danli + + TR_URB2D_mosaic(I,mosaic_i,J)=TR_URB2D(I,J) + TB_URB2D_mosaic(I,mosaic_i,J)=TB_URB2D(I,J) + TG_URB2D_mosaic(I,mosaic_i,J)=TG_URB2D(I,J) + TC_URB2D_mosaic(I,mosaic_i,J)=TC_URB2D(I,J) + QC_URB2D_mosaic(I,mosaic_i,J)=QC_URB2D(I,J) + UC_URB2D_mosaic(I,mosaic_i,J)=UC_URB2D(I,J) + TS_URB2D_mosaic(I,mosaic_i,J)=TS_URB2D(I,J) + TS_RUL2D_mosaic(I,mosaic_i,J)=T1 + + DO K = 1,num_roof_layers + TRL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TRL_URB3D(I,K,J) + END DO + DO K = 1,num_wall_layers + TBL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TBL_URB3D(I,K,J) + END DO + DO K = 1,num_road_layers + TGL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TGL_URB3D(I,K,J) + END DO + + SH_URB2D_mosaic(I,mosaic_i,J) = SH_URB2D(I,J) + LH_URB2D_mosaic(I,mosaic_i,J) = LH_URB2D(I,J) + G_URB2D_mosaic(I,mosaic_i,J) = G_URB2D(I,J) + RN_URB2D_mosaic(I,mosaic_i,J) = RN_URB2D(I,J) + + END IF + + ENDIF ! end of UCM CALL if block + !-------------------------------------- + ! Urban Part End - urban + !-------------------------------------- + + !*** DIAGNOSTICS + SMSTAV(I,J)=SOILW + SMSTOT(I,J)=SOILM*1000. + DO NS=1,NSOIL + SMCREL(I,NS,J)=SMAV(NS) + ENDDO + + ! Convert the water unit into mm + SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0 + UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0 + ! snow defined when fraction of frozen precip (FFROZP) > 0.5, + IF(FFROZP.GT.0.5)THEN + ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT + ENDIF + IF(SNOW(I,J).GT.0.)THEN + ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000. + ! accumulated snow-melt energy + SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW + ENDIF + + ENDIF ! endif of land-sea test + + !----------------------------------------------------------------------- + ! Done with the Noah-UCM MOSAIC DANLI + !----------------------------------------------------------------------- + + TSK_mosaic(i,mosaic_i,j)=TSK(i,j) ! from 2D to 3D + QSFC_mosaic(i,mosaic_i,j)=QSFC(i,j) + CANWAT_mosaic(i,mosaic_i,j)=CANWAT(i,j) + SNOW_mosaic(i,mosaic_i,j)=SNOW(i,j) + SNOWH_mosaic(i,mosaic_i,j)=SNOWH(i,j) + SNOWC_mosaic(i,mosaic_i,j)=SNOWC(i,j) + + ALBEDO_mosaic(i,mosaic_i,j)=ALBEDO(i,j) + ALBBCK_mosaic(i,mosaic_i,j)=ALBBCK(i,j) + EMISS_mosaic(i,mosaic_i,j)=EMISS(i,j) + EMBCK_mosaic(i,mosaic_i,j)=EMBCK(i,j) + ZNT_mosaic(i,mosaic_i,j)=ZNT(i,j) + Z0_mosaic(i,mosaic_i,j)=Z0(i,j) + LAI_mosaic(i,mosaic_i,j)=XLAI + RC_mosaic(i,mosaic_i,j)=RC + + HFX_mosaic(i,mosaic_i,j)=HFX(i,j) + QFX_mosaic(i,mosaic_i,j)=QFX(i,j) + LH_mosaic(i,mosaic_i,j)=LH(i,j) + GRDFLX_mosaic(i,mosaic_i,j)=GRDFLX(i,j) + SNOTIME_mosaic(i,mosaic_i,j)=SNOTIME(i,j) + + DO NS=1,NSOIL + + TSLB_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=TSLB(i,NS,j) + SMOIS_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=SMOIS(i,NS,j) + SH2O_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=SH2O(i,NS,j) + + ENDDO + +#if 0 + IF(TSK_mosaic(i,mosaic_i,j) > 350 .OR. TSK_mosaic(i,mosaic_i,j) < 250 .OR. abs(HFX_mosaic(i,mosaic_i,j)) > 700 ) THEN + print*, 'I', I, 'J', J, 'MOSAIC_I', MOSAIC_I + print*, 'mosaic_cat_index',mosaic_cat_index(I,mosaic_i,J), 'landusef2',landusef2(i,mosaic_i,j) + print*, 'TSK_mosaic', TSK_mosaic(i,mosaic_i,j), 'HFX_mosaic', HFX_mosaic(i,mosaic_i,j), & + 'LH_mosaic',LH_mosaic(i,mosaic_i,j),'GRDFLX_mosaic',GRDFLX_mosaic(i,mosaic_i,j) + print*, 'ZNT_mosaic', ZNT_mosaic(i, mosaic_i,j), 'Z0_mosaic', Z0_mosaic(i,mosaic_i,j) + print*, 'LAI_mosaic', LAI_mosaic(i, mosaic_i,j) + print*, 'FRC_URB2D',FRC_URB2D(I,J) + print*, 'TS_URB',TS_URB2D(I,J),'T1',T1 + print*, 'SH_URB2D',SH_URB2D(I,J),'SHEAT',SHEAT + print*, 'LH_URB',LH_URB2D(I,J),'ETA',ETA + print*, 'TS_RUL2D',TS_RUL2D_mosaic(I,mosaic_i,J) + + ENDIF +#endif + + !----------------------------------------------------------------------- + ! Now let's do the grid-averaging + !----------------------------------------------------------------------- + + FAREA = landusef2(i,mosaic_i,j) + + TSK_mosaic_avg(i,j) = TSK_mosaic_avg(i,j) + (EMISS_mosaic(i,mosaic_i,j)*TSK_mosaic(i,mosaic_i,j)**4)*FAREA ! conserve the longwave radiation + + QSFC_mosaic_avg(i,j) = QSFC_mosaic_avg(i,j) + QSFC_mosaic(i,mosaic_i,j)*FAREA + CANWAT_mosaic_avg(i,j) = CANWAT_mosaic_avg(i,j) + CANWAT_mosaic(i,mosaic_i,j)*FAREA + SNOW_mosaic_avg(i,j) = SNOW_mosaic_avg(i,j) + SNOW_mosaic(i,mosaic_i,j)*FAREA + SNOWH_mosaic_avg(i,j) = SNOWH_mosaic_avg(i,j) + SNOWH_mosaic(i,mosaic_i,j)*FAREA + SNOWC_mosaic_avg(i,j) = SNOWC_mosaic_avg(i,j) + SNOWC_mosaic(i,mosaic_i,j)*FAREA + + DO NS=1,NSOIL + + TSLB_mosaic_avg(i,NS,j)=TSLB_mosaic_avg(i,NS,j) + TSLB_mosaic(i,NS*mosaic_i,j)*FAREA + SMOIS_mosaic_avg(i,NS,j)=SMOIS_mosaic_avg(i,NS,j) + SMOIS_mosaic(i,NS*mosaic_i,j)*FAREA + SH2O_mosaic_avg(i,NS,j)=SH2O_mosaic_avg(i,NS,j) + SH2O_mosaic(i,NS*mosaic_i,j)*FAREA + + ENDDO + + FAREA_mosaic_avg(i,j)=FAREA_mosaic_avg(i,j)+FAREA + HFX_mosaic_avg(i,j) = HFX_mosaic_avg(i,j) + HFX_mosaic(i,mosaic_i,j)*FAREA + QFX_mosaic_avg(i,j) = QFX_mosaic_avg(i,j) + QFX_mosaic(i,mosaic_i,j)*FAREA + LH_mosaic_avg(i,j) = LH_mosaic_avg(i,j) + LH_mosaic(i,mosaic_i,j)*FAREA + GRDFLX_mosaic_avg(i,j)=GRDFLX_mosaic_avg(i,j)+GRDFLX_mosaic(i,mosaic_i,j)*FAREA + + ALBEDO_mosaic_avg(i,j)=ALBEDO_mosaic_avg(i,j)+ALBEDO_mosaic(i,mosaic_i,j)*FAREA + ALBBCK_mosaic_avg(i,j)=ALBBCK_mosaic_avg(i,j)+ALBBCK_mosaic(i,mosaic_i,j)*FAREA + EMISS_mosaic_avg(i,j)=EMISS_mosaic_avg(i,j)+EMISS_mosaic(i,mosaic_i,j)*FAREA + EMBCK_mosaic_avg(i,j)=EMBCK_mosaic_avg(i,j)+EMBCK_mosaic(i,mosaic_i,j)*FAREA + ZNT_mosaic_avg(i,j)=ZNT_mosaic_avg(i,j)+ALOG(ZNT_mosaic(i,mosaic_i,j))*FAREA + Z0_mosaic_avg(i,j)=Z0_mosaic_avg(i,j)+ALOG(Z0_mosaic(i,mosaic_i,j))*FAREA + LAI_mosaic_avg(i,j)=LAI_mosaic_avg(i,j)+LAI_mosaic(i,mosaic_i,j)*FAREA + if(RC_mosaic(i,mosaic_i,j) .Gt. 0.0) Then + RC_mosaic_avg(i,j) = RC_mosaic_avg(i,j)+1.0/RC_mosaic(i,mosaic_i,j)*FAREA + else + RC_mosaic_avg(i,j) = RC_mosaic_avg(i,j) + RC_mosaic(i,mosaic_i,j)*FAREA + End If + ENDDO ! ENDDO FOR mosaic_i = 1, mosaic_cat + + !----------------------------------------------------------------------- + ! Now let's send the 3D values to the 2D variables that might be needed in other routines + !----------------------------------------------------------------------- + + IVGTYP(I,J)=IVGTYP_dominant(I,J) ! the dominant vege category + ALBEDO(i,j)=ALBEDO_mosaic_avg(i,j) + ALBBCK(i,j)=ALBBCK_mosaic_avg(i,j) + EMISS(i,j)= EMISS_mosaic_avg(i,j) + EMBCK(i,j)= EMBCK_mosaic_avg(i,j) + ZNT(i,j)= EXP(ZNT_mosaic_avg(i,j)/FAREA_mosaic_avg(i,j)) + Z0(i,j)= EXP(Z0_mosaic_avg(i,j)/FAREA_mosaic_avg(i,j)) + XLAI2(i,j)= LAI_mosaic_avg(i,j) + IF (RC_mosaic_avg(i,j) .Gt. 0.0) THEN + rc2(i,j) = 1.0/(RC_mosaic_avg(i,j)) + ELSE +!RC_mosaic_avg was zero for all tiles (cell over water), thus RC2 set to zero to avoid infinity + rc2(i,j) = RC_mosaic_avg(i,j) + END IF + TSK(i,j)=(TSK_mosaic_avg(I,J)/EMISS_mosaic_avg(I,J))**(0.25) ! from 3D to 2D + QSFC(i,j)=QSFC_mosaic_avg(I,J) + CANWAT(i,j) = CANWAT_mosaic_avg(i,j) + SNOW(i,j) = SNOW_mosaic_avg(i,j) + SNOWH(i,j) = SNOWH_mosaic_avg(i,j) + SNOWC(i,j) = SNOWC_mosaic_avg(i,j) + + HFX(i,j) = HFX_mosaic_avg(i,j) + QFX(i,j) = QFX_mosaic_avg(i,j) + LH(i,j) = LH_mosaic_avg(i,j) + GRDFLX(i,j)=GRDFLX_mosaic_avg(i,j) + + DO NS=1,NSOIL + + TSLB(i,NS,j)=TSLB_mosaic_avg(i,NS,j) + SMOIS(i,NS,j)=SMOIS_mosaic_avg(i,NS,j) + SH2O(i,NS,j)=SH2O_mosaic_avg(i,NS,j) + + ENDDO + + ELSE ! This corresponds to IF ((sf_surface_mosaic == 1) .AND. ((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN + + ! surface pressure + PSFC=P8w3D(i,1,j) + ! pressure in middle of lowest layer + SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5 + ! convert from mixing ratio to specific humidity + Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j)) + ! + ! Q2SAT=QGH(I,j) + Q2SAT=QGH(I,J)/(1.0+QGH(I,J)) ! Q2SAT is sp humidity + ! add check on myj=.true. + ! IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN + IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN + SATFLG=0. + CHKLOWQ(I,J)=0. + ELSE + SATFLG=1.0 + CHKLOWQ(I,J)=1. + ENDIF + + SFCTMP=T3D(i,1,j) + ZLVL=0.5*DZ8W(i,1,j) + + ! TH2=SFCTMP+(0.0097545*ZLVL) + ! calculate SFCTH2 via Exner function vs lapse-rate (above) + APES=(1.E5/PSFC)**CAPA + APELM=(1.E5/SFCPRS)**CAPA + SFCTH2=SFCTMP*APELM + TH2=SFCTH2/APES + ! + EMISSI = EMISS(I,J) + LWDN=GLW(I,J)*EMISSI + ! SOLDN is total incoming solar + SOLDN=SWDOWN(I,J) + ! GSW is net downward solar + ! SOLNET=GSW(I,J) + ! use mid-day albedo to determine net downward solar (no solar zenith angle correction) + SOLNET=SOLDN*(1.-ALBEDO(I,J)) + PRCP=RAINBL(i,j)/DT + VEGTYP=IVGTYP(I,J) + SOILTYP=ISLTYP(I,J) + SHDFAC=VEGFRA(I,J)/100. + T1=TSK(I,J) + CHK=CHS(I,J) + SHMIN=SHDMIN(I,J)/100. !NEW + SHMAX=SHDMAX(I,J)/100. !NEW + ! convert snow water equivalent from mm to meter + SNEQV=SNOW(I,J)*0.001 + ! snow depth in meters + SNOWHK=SNOWH(I,J) + SNCOVR=SNOWC(I,J) + + ! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1) + ! SR from e.g. Ferrier microphysics + ! otherwise define from 1st atmos level temperature + IF(FRPCPN) THEN + FFROZP=SR(I,J) + ELSE + IF (SFCTMP <= 273.15) THEN + FFROZP = 1.0 + ELSE + FFROZP = 0.0 + ENDIF + ENDIF + !*** + IF((XLAND(I,J)-1.5).GE.0.)THEN ! begining of land/sea if block + ! Open water points + TSK_RURAL(I,J)=TSK(I,J) + HFX_RURAL(I,J)=HFX(I,J) + QFX_RURAL(I,J)=QFX(I,J) + LH_RURAL(I,J)=LH(I,J) + EMISS_RURAL(I,J)=EMISS(I,J) + GRDFLX_RURAL(I,J)=GRDFLX(I,J) + ELSE + ! Land or sea-ice case + + IF (XICE(I,J) >= XICE_THRESHOLD) THEN + ! Sea-ice point + ICE = 1 + ELSE IF ( VEGTYP == ISICE ) THEN + ! Land-ice point + ICE = -1 + ELSE + ! Neither sea ice or land ice. + ICE=0 + ENDIF + DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2 + + IF(SNOW(I,J).GT.0.0)THEN + ! snow on surface (use ice saturation properties) + SFCTSNO=SFCTMP + E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO)) + Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT) + Q2SATI=Q2SATI/(1.0+Q2SATI) ! spec. hum. + IF (T1 .GT. 273.14) THEN + ! warm ground temps, weight the saturation between ice and water according to SNOWC + Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J) + DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J) + ELSE + ! cold ground temps, use ice saturation only + Q2SAT=Q2SATI + DQSDT2=Q2SATI*6174./(SFCTSNO**2) + ENDIF + ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero + IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + ENDIF + + ! Land-ice or land points use the usual deep-soil temperature. + TBOT=TMN(I,J) + + IF(VEGTYP.EQ.25) SHDFAC=0.0000 + IF(VEGTYP.EQ.26) SHDFAC=0.0000 + IF(VEGTYP.EQ.27) SHDFAC=0.0000 + IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN +#if 0 + IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' + IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F' +#endif + SOILTYP=7 + ENDIF + SNOALB1 = SNOALB(I,J) + CMC=CANWAT(I,J)/1000. + + !------------------------------------------- + !*** convert snow depth from mm to meter + ! + ! IF(RDMAXALB) THEN + ! SNOALB=ALBMAX(I,J)*0.01 + ! ELSE + ! SNOALB=MAXALB(IVGTPK)*0.01 + ! ENDIF + + ! SNOALB1=0.80 + ! SHMIN=0.00 + ALBBRD=ALBBCK(I,J) + Z0BRD=Z0(I,J) + EMBRD=EMBCK(I,J) + SNOTIME1 = SNOTIME(I,J) + RIBB=RIB(I,J) + !FEI: temporaray arrays above need to be changed later by using SI + + DO NS=1,NSOIL + SMC(NS)=SMOIS(I,NS,J) + STC(NS)=TSLB(I,NS,J) !STEMP + SWC(NS)=SH2O(I,NS,J) + ENDDO + ! + if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN + SNOWHK= 5.*SNEQV + endif + ! + + !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as + ! the "NATURAL" category in the VEGPARM.TBL + IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN + + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + VEGTYP = NATURAL + SHDFAC = SHDTBL(NATURAL) + ALBEDOK =0.2 ! 0.2 + ALBBRD =0.2 !0.2 + EMISSI = 0.98 !for VEGTYP=5 + LWDN = GLW(I,J) * EMISSI + SOLNET = SOLDN * (1.0 - ALBEDOK) + + IF ( FRC_URB2D(I,J) < 0.99 ) THEN + if(sf_urban_physics.eq.1)then + T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J)) + elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then + T1=tsk_rural_bep(i,j) + endif + ELSE + T1 = TSK(I,J) + ENDIF + ENDIF + ELSE + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + VEGTYP = ISURBAN + ENDIF + ENDIF + + +!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== + AOASIS = 1.0 + USOIL = 1 + DSOIL = 2 + IRIOPTION=IRI_SCHEME + OMG= OMG_URB2D(I,J) + tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24) + if (tloc.lt.0) tloc=tloc+24 + if (tloc==0) tloc=24 + CALL cal_mon_day(julian,julyr,jmonth,jday) + IF(SF_URBAN_PHYSICS == 1) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + AOASIS = oasis ! urban oasis effect + IF (IRIOPTION ==1) THEN + IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm + IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN + IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J)) + IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J)) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + IF(AOASIS > 1.0) THEN + CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + IF(IRIOPTION == 1) THEN + CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + ENDIF + +#if 0 + IF(IPRINT) THEN + ! + print*, 'BEFORE SFLX, in Noahlsm_driver' + print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, & + 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',& + LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, & + 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, & + 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,& + 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,& + 'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',& + TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',& + STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,& + 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, & + 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, & + 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,& + 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,& + 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,& + 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, & + 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, & + 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, & + 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,& + 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT + endif +#endif + + IF (rdlai2d) THEN + xlai = lai(i,j) + endif + + IF ( ICE == 1 ) THEN + + ! Sea-ice case + + DO NS = 1, NSOIL + SH2O(I,NS,J) = 1.0 + ENDDO + LAI(I,J) = 0.01 + + CYCLE ILOOP + + ELSEIF (ICE == 0) THEN + + ! Non-glacial land + + CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & +! WRF_HYDRO vars + sfcheadrt_hydro, & !I + INFXSRT_hydro,ETPND1_hydro & !O + ,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars + ,IRRIGATION_CHANNEL ) + +#ifdef WRF_HYDRO + soldrain(i,j) = RUNOFF2*DT*1000.0 + sfcheadrt(i,j) = sfcheadrt_hydro + infxsrt(i,j) = INFXSRT_hydro + etpnd1 = etpnd1_hydro +#endif + ELSEIF (ICE == -1) THEN + + ! + ! Set values that the LSM is expected to update, + ! but don't get updated for glacial points. + ! + SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero + XLAI = 0.01 ! KWM Should this be Zero over land ice? Does this value matter? + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + DO NS = 1, NSOIL + SWC(NS) = 1.0 + SMC(NS) = 1.0 + SMAV(NS) = 1.0 + ENDDO + CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C + & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K, & !F + & TH2,Q2SAT,DQSDT2, & !I + & ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + & T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK, & !H + & ETA,SHEAT,ETA_KINEMATIC,FDOWN, & !O + & ESNOW,DEW, & !O + & ETP,SSOIL, & !O + & FLX1,FLX2,FLX3, & !O + & SNOMLT,SNCOVR, & !O + & RUNOFF1, & !O + & Q1, & !D + & SNOTIME1, & + & RIBB) + + ENDIF + + lai(i,j) = xlai + +#if 0 + IF(IPRINT) THEN + + print*, 'AFTER SFLX, in Noahlsm_driver' + print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL, & + 'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',& + LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN, & + 'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K, & + 'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,& + 'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,& + 'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',& + TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',& + STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,& + 'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT, & + 'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC, & + 'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,& + 'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,& + 'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,& + 'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, & + 'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS, & + 'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW, & + 'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,& + 'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT + endif +#endif + + !*** UPDATE STATE VARIABLES + CANWAT(I,J)=CMC*1000. + SNOW(I,J)=SNEQV*1000. + ! SNOWH(I,J)=SNOWHK*1000. + SNOWH(I,J)=SNOWHK ! SNOWHK in meters + ALBEDO(I,J)=ALBEDOK + ALB_RURAL(I,J)=ALBEDOK + ALBBCK(I,J)=ALBBRD + Z0(I,J)=Z0BRD + EMISS(I,J) = EMISSI + EMISS_RURAL(I,J) = EMISSI + ! Noah: activate time-varying roughness length (V3.3 Feb 2011) + ZNT(I,J)=Z0K + TSK(I,J)=T1 + TSK_RURAL(I,J)=T1 + HFX(I,J)=SHEAT + HFX_RURAL(I,J)=SHEAT + ! MEk Jul07 add potential evap accum + POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW + QFX(I,J)=ETA_KINEMATIC + QFX_RURAL(I,J)=ETA_KINEMATIC + +#ifdef WRF_HYDRO + !added by Wei Yu + ! QFX(I,J) = QFX(I,J) + ETPND1 + ! ETA = ETA + ETPND1/2.501E6*dt + !end added by Wei Yu +#endif + + LH(I,J)=ETA + LH_RURAL(I,J)=ETA + GRDFLX(I,J)=SSOIL + GRDFLX_RURAL(I,J)=SSOIL + SNOWC(I,J)=SNCOVR + CHS2(I,J)=CQS2(I,J) + SNOTIME(I,J) = SNOTIME1 + ! prevent diagnostic ground q (q1) from being greater than qsat(tsk) + ! as happens over snow cover where the cqs2 value also becomes irrelevant + ! by setting cqs2=chs in this situation the 2m q should become just qv(k=1) + IF (Q1 .GT. QSFC(I,J)) THEN + CQS2(I,J) = CHS(I,J) + ENDIF + ! QSFC(I,J)=Q1 + ! Convert QSFC back to mixing ratio + QSFC(I,J)= Q1/(1.0-Q1) + ! + ! QSFC_RURAL(I,J)= Q1/(1.0-Q1) + ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002) + + DO 80 NS=1,NSOIL + SMOIS(I,NS,J)=SMC(NS) + TSLB(I,NS,J)=STC(NS) ! STEMP + SH2O(I,NS,J)=SWC(NS) + 80 CONTINUE + ! ENDIF + + FLX4_2D(I,J) = FLX4 + FVB_2D(I,J) = FVB + FBUR_2D(I,J) = FBUR + FGSN_2D(I,J) = FGSN + ! + ! Residual of surface energy balance equation terms + ! + + IF ( UA_PHYS ) THEN + noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta & + - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4 + + ELSE + noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta & + - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 + ENDIF + + IF (SF_URBAN_PHYSICS == 1 ) THEN ! Beginning of UCM CALL if block + !-------------------------------------- + ! URBAN CANOPY MODEL START - urban + !-------------------------------------- + ! Input variables lsm --> urban + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LCZ_1 .or. IVGTYP(I,J) == LCZ_2 .or. & + IVGTYP(I,J) == LCZ_3 .or. IVGTYP(I,J) == LCZ_4 .or. IVGTYP(I,J) == LCZ_5 .or. & + IVGTYP(I,J) == LCZ_6 .or. IVGTYP(I,J) == LCZ_7 .or. IVGTYP(I,J) == LCZ_8 .or. & + IVGTYP(I,J) == LCZ_9 .or. IVGTYP(I,J) == LCZ_10 .or. IVGTYP(I,J) == LCZ_11 ) THEN + + ! Call urban + ! + UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) + + TA_URB = SFCTMP ! [K] + QA_URB = Q2K ! [kg/kg] + UA_URB = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.) + U1_URB = U_PHY(I,1,J) + V1_URB = V_PHY(I,1,J) + IF(UA_URB < 1.) UA_URB=1. ! [m/s] + SSG_URB = SOLDN ! [W/m/m] + SSGD_URB = 0.8*SOLDN ! [W/m/m] + SSGQ_URB = SSG_URB-SSGD_URB ! [W/m/m] + LLG_URB = GLW(I,J) ! [W/m/m] + RAIN_URB = RAINBL(I,J) / DT * 3600.0 ! [mm/hr] + RHOO_URB = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] + ZA_URB = ZLVL ! [m] + DELT_URB = DT ! [sec] + XLAT_URB = XLAT_URB2D(I,J) ! [deg] + COSZ_URB = COSZ_URB2D(I,J) ! + OMG_URB = OMG_URB2D(I,J) ! + ZNT_URB = ZNT(I,J) + + LSOLAR_URB = .FALSE. + + TR_URB = TR_URB2D(I,J) + TB_URB = TB_URB2D(I,J) + TG_URB = TG_URB2D(I,J) + TC_URB = TC_URB2D(I,J) + QC_URB = QC_URB2D(I,J) + UC_URB = UC_URB2D(I,J) + + DO K = 1,num_roof_layers + TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) + END DO + DO K = 1,num_wall_layers + TBL_URB(K) = TBL_URB3D(I,K,J) + END DO + DO K = 1,num_road_layers + TGL_URB(K) = TGL_URB3D(I,K,J) + END DO + + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) + + XXXR_URB = XXXR_URB2D(I,J) + XXXB_URB = XXXB_URB2D(I,J) + XXXG_URB = XXXG_URB2D(I,J) + XXXC_URB = XXXC_URB2D(I,J) + ! + ! Limits to avoid dividing by small number + if (CHS(I,J) < 1.0E-02) then + CHS(I,J) = 1.0E-02 + endif + if (CHS2(I,J) < 1.0E-02) then + CHS2(I,J) = 1.0E-02 + endif + if (CQS2(I,J) < 1.0E-02) then + CQS2(I,J) = 1.0E-02 + endif + ! + CHS_URB = CHS(I,J) + CHS2_URB = CHS2(I,J) + IF (PRESENT(CMR_SFCDIF)) THEN + CMR_URB = CMR_SFCDIF(I,J) + CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) + CMC_URB = CMC_SFCDIF(I,J) + CHC_URB = CHC_SFCDIF(I,J) + ENDIF + + ! NUDAPT for SLUCM + mh_urb = mh_urb2d(I,J) + stdh_urb = stdh_urb2d(I,J) + lp_urb = lp_urb2d(I,J) + hgt_urb = hgt_urb2d(I,J) + lf_urb = 0.0 + DO K = 1,4 + lf_urb(K)=lf_urb2d(I,K,J) + ENDDO + frc_urb = frc_urb2d(I,J) + lb_urb = lb_urb2d(I,J) + check = 0 + if (I.eq.73.and.J.eq.125)THEN + check = 1 + end if + ! + ! Call urban + CALL cal_mon_day(julian,julyr,jmonth,jday) + CALL urban(LSOLAR_URB, & ! I + num_roof_layers,num_wall_layers,num_road_layers, & ! C + DZR,DZB,DZG, & ! C + UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I + SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB, & ! I + ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB, & ! I + XLAT_URB,DELT_URB,ZNT_URB, & ! I + CHS_URB, CHS2_URB, & ! I + TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB, & ! H + TRL_URB,TBL_URB,TGL_URB, & ! H + XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB, & ! H + TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB, & ! O + SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O + GZ1OZ0_URB, & !O + CMR_URB, CHR_URB, CMC_URB, CHC_URB, & + U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O + UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) + +#if 0 + IF(IPRINT) THEN + + print*, 'AFTER CALL URBAN' + print*,'num_roof_layers',num_roof_layers, 'num_wall_layers', & + num_wall_layers, & + 'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', & + TA_URB, & + 'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB', & + V1_URB, & + 'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB, & + 'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB, & + 'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,& + 'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB, & + 'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',& + TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB, & + 'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB, & + 'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,& + 'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB', & + LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,& + 'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB', & + RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB, & + 'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB, & + 'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB + endif +#endif + + TS_URB2D(I,J) = TS_URB + + ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK ![-] + HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT ![W/m/m] + QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB & + + (1-FRC_URB2D(I,J))*ETA_KINEMATIC ![kg/m/m/s] + LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA ![W/m/m] + GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL ![W/m/m] + TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1 ![K] + Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1 ![-] + ! Convert QSFC back to mixing ratio + QSFC(I,J)= Q1/(1.0-Q1) + UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J) ![m/s] + +#if 0 + IF(IPRINT)THEN + + print*, ' FRC_URB2D', FRC_URB2D, & + 'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, & + 'ALBEDO(I,J)', ALBEDO(I,J), & + 'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J), & + 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC', & + ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J), & + 'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J), & + 'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),& + 'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J), & + 'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J) + endif +#endif + + ! Renew Urban State Varialbes + + TR_URB2D(I,J) = TR_URB + TB_URB2D(I,J) = TB_URB + TG_URB2D(I,J) = TG_URB + TC_URB2D(I,J) = TC_URB + QC_URB2D(I,J) = QC_URB + UC_URB2D(I,J) = UC_URB + + DO K = 1,num_roof_layers + TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) + END DO + DO K = 1,num_wall_layers + TBL_URB3D(I,K,J) = TBL_URB(K) + END DO + DO K = 1,num_road_layers + TGL_URB3D(I,K,J) = TGL_URB(K) + END DO + + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + + XXXR_URB2D(I,J) = XXXR_URB + XXXB_URB2D(I,J) = XXXB_URB + XXXG_URB2D(I,J) = XXXG_URB + XXXC_URB2D(I,J) = XXXC_URB + + SH_URB2D(I,J) = SH_URB + LH_URB2D(I,J) = LH_URB + G_URB2D(I,J) = G_URB + RN_URB2D(I,J) = RN_URB + PSIM_URB2D(I,J) = PSIM_URB + PSIH_URB2D(I,J) = PSIH_URB + GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB + U10_URB2D(I,J) = U10_URB + V10_URB2D(I,J) = V10_URB + TH2_URB2D(I,J) = TH2_URB + Q2_URB2D(I,J) = Q2_URB + UST_URB2D(I,J) = UST_URB + AKMS_URB2D(I,J) = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J)) + IF (PRESENT(CMR_SFCDIF)) THEN + CMR_SFCDIF(I,J) = CMR_URB + CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB + CMC_SFCDIF(I,J) = CMC_URB + CHC_SFCDIF(I,J) = CHC_URB + ENDIF + END IF + + ENDIF ! end of UCM CALL if block + !-------------------------------------- + ! Urban Part End - urban + !-------------------------------------- + + !*** DIAGNOSTICS + SMSTAV(I,J)=SOILW + SMSTOT(I,J)=SOILM*1000. + DO NS=1,NSOIL + SMCREL(I,NS,J)=SMAV(NS) + ENDDO + + ! Convert the water unit into mm + SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0 + UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0 + ! snow defined when fraction of frozen precip (FFROZP) > 0.5, + IF(FFROZP.GT.0.5)THEN + ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT + ENDIF + IF(SNOW(I,J).GT.0.)THEN + ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000. + ! accumulated snow-melt energy + SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW + ENDIF + + ENDIF ! endif of land-sea test + + ENDIF ! ENDIF FOR MOSAIC DANLI ! This corresponds to IF ((sf_surface_mosaic == 1) .AND. ((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN + + ENDDO ILOOP ! of I loop + ENDDO JLOOP ! of J loop + +!------------------------------------------------------ + END SUBROUTINE lsm_mosaic +!------------------------------------------------------ +!=========================================================================== +! +! subroutine lsm_mosaic_init: initialization of mosaic state variables +! +!=========================================================================== + + SUBROUTINE lsm_mosaic_init(IVGTYP,ISWATER,ISURBAN,ISICE, XLAND, XICE,fractional_seaice, & + TSK,TSLB,SMOIS,SH2O,SNOW,SNOWC,SNOWH,CANWAT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, restart, & + landusef,landusef2,NLCAT,num_soil_layers & + ,sf_surface_mosaic, mosaic_cat & + ,mosaic_cat_index & + ,TSK_mosaic,TSLB_mosaic & + ,SMOIS_mosaic,SH2O_mosaic & + ,CANWAT_mosaic,SNOW_mosaic & + ,SNOWH_mosaic,SNOWC_mosaic & + ,ALBEDO,ALBBCK, EMISS, EMBCK,Z0 & !danli + ,ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic & !danli + ,EMBCK_mosaic, ZNT_mosaic, Z0_mosaic & !danli + ,TR_URB2D_mosaic,TB_URB2D_mosaic & !danli mosaic + ,TG_URB2D_mosaic,TC_URB2D_mosaic & !danli mosaic + ,QC_URB2D_mosaic & !danli mosaic + ,TRL_URB3D_mosaic,TBL_URB3D_mosaic & !danli mosaic + ,TGL_URB3D_mosaic & !danli mosaic + ,SH_URB2D_mosaic,LH_URB2D_mosaic & !danli mosaic + ,G_URB2D_mosaic,RN_URB2D_mosaic & !danli mosaic + ,TS_URB2D_mosaic & !danli mosaic + ,TS_RUL2D_mosaic & !danli mosaic + ) + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN) :: NLCAT, num_soil_layers, ISWATER,ISURBAN, ISICE, fractional_seaice + + LOGICAL , INTENT(IN) :: restart + +! REAL, DIMENSION( num_soil_layers), INTENT(INOUT) :: ZS, DZS + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & + INTENT(IN) :: SMOIS, & !Total soil moisture + SH2O, & !liquid soil moisture + TSLB !STEMP + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN) :: SNOW, & + SNOWH, & + SNOWC, & + CANWAT, & + TSK, XICE, XLAND + + INTEGER, INTENT(IN) :: sf_surface_mosaic + INTEGER, INTENT(IN) :: mosaic_cat + INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(IN) :: IVGTYP + REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , INTENT(IN):: LANDUSEF + REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , INTENT(INOUT):: LANDUSEF2 + + INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) :: mosaic_cat_index + + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: & + TSK_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic + REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT):: & + TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic + + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN):: ALBEDO, ALBBCK, EMISS, EMBCK, Z0 + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: & + ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic + + REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT):: & + TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic, & + SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic + + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic + + INTEGER :: ij,i,j,mosaic_i,LastSwap,NumPairs,soil_k, Temp2,Temp5,Temp7, ICE,temp_index + REAL :: Temp, Temp3,Temp4,Temp6,xice_threshold + LOGICAL :: IPRINT + CHARACTER(len=256) :: message_text + + IPRINT=.false. + + if ( fractional_seaice == 0 ) then + xice_threshold = 0.5 + else if ( fractional_seaice == 1 ) then + xice_threshold = 0.02 + endif + + IF(.not.restart)THEN + !=========================================================================== + ! CHOOSE THE TILES + !=========================================================================== + + itf=min0(ite,ide-1) + jtf=min0(jte,jde-1) + + ! simple test + + DO i = its,itf + DO j = jts,jtf + IF ((xland(i,j).LT. 1.5 ) .AND. (IVGTYP(i,j) .EQ. ISWATER)) THEN + PRINT*, 'BEFORE MOSAIC_INIT' + CALL wrf_message("BEFORE MOSAIC_INIT") + WRITE(message_text,fmt='(a,2I6,2F8.2,2I6)') 'I,J,xland,xice,mosaic_cat_index,ivgtyp = ', & + I,J,xland(i,j),xice(i,j),mosaic_cat_index(I,1,J),IVGTYP(i,j) + CALL wrf_message(message_text) + ENDIF + ENDDO + ENDDO + + DO i = its,itf + DO j = jts,jtf + DO mosaic_i=1,NLCAT + LANDUSEF2(i,mosaic_i,j)=LANDUSEF(i,mosaic_i,j) + mosaic_cat_index(i,mosaic_i,j)=mosaic_i + ENDDO + ENDDO + ENDDO + + DO i = its,itf + DO j = jts,jtf + + NumPairs=NLCAT-1 + + DO + IF (NumPairs == 0) EXIT + LastSwap = 1 + DO mosaic_i=1, NumPairs + IF(LANDUSEF2(i,mosaic_i, j) < LANDUSEF2(i,mosaic_i+1, j) ) THEN + Temp = LANDUSEF2(i,mosaic_i, j) + LANDUSEF2(i,mosaic_i, j)=LANDUSEF2(i,mosaic_i+1, j) + LANDUSEF2(i,mosaic_i+1, j)=Temp + LastSwap = mosaic_i + + Temp2 = mosaic_cat_index(i,mosaic_i,j) + mosaic_cat_index(i,mosaic_i,j)=mosaic_cat_index(i,mosaic_i+1,j) + mosaic_cat_index(i,mosaic_i+1,j)=Temp2 + ENDIF + ENDDO + NumPairs = LastSwap - 1 + ENDDO + + ENDDO + ENDDO + + !=========================================================================== + ! For non-seaice grids, eliminate the seaice-tiles + !=========================================================================== + + DO i = its,itf + DO j = jts,jtf + + IF (XLAND(I,J).LT.1.5) THEN + + ICE = 0 + IF( XICE(I,J).GE. XICE_THRESHOLD ) THEN + WRITE (message_text,fmt='(a,2I5)') 'sea-ice at point, I and J = ', i,j + CALL wrf_message(message_text) + ICE = 1 + ENDIF + + IF (ICE == 1) Then ! sea-ice case , eliminate sea-ice if they are not the dominant ones + + IF (IVGTYP(i,j) == isice) THEN ! if this grid cell is dominanted by ice, then do nothing + + ELSE + + DO mosaic_i=2,mosaic_cat + IF (mosaic_cat_index(i,mosaic_i,j) == isice ) THEN + Temp4=LANDUSEF2(i,mosaic_i,j) + Temp5=mosaic_cat_index(i,mosaic_i,j) + + LANDUSEF2(i,mosaic_i:NLCAT-1,j)=LANDUSEF2(i,mosaic_i+1:NLCAT,j) + mosaic_cat_index(i,mosaic_i:NLCAT-1,j)=mosaic_cat_index(i,mosaic_i+1:NLCAT,j) + + LANDUSEF2(i,NLCAT,j)=Temp4 + mosaic_cat_index(i,NLCAT,j)=Temp5 + ENDIF + ENDDO + + ENDIF ! for (IVGTYP(i,j) == isice ) + + ELSEIF (ICE ==0) THEN + + IF ((mosaic_cat_index(I,1,J) .EQ. ISWATER)) THEN + + ! xland < 1.5 but the dominant land use category based on our calculation is water + + IF (IVGTYP(i,j) .EQ. ISWATER) THEN + + ! xland < 1.5 but the dominant land use category based on the geogrid calculation is water, this must be wrong + + CALL wrf_message("IN MOSAIC_INIT") + WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j) + CALL wrf_message(message_text) + CALL wrf_message("xland < 1.5 but the dominant land use category based on our calculation is water."//& + "In addition, the dominant land use category based on the geogrid calculation is water, this must be wrong") + + ENDIF ! for (IVGTYP(i,j) .EQ. ISWATER) + + IF (IVGTYP(i,j) .NE. ISWATER) THEN + + ! xland < 1.5, the dominant land use category based on our calculation is water, but based on the geogrid calculation is not water, which might be due to the inconsistence between land use data and land-sea mask + + Temp4=LANDUSEF2(i,1,j) + Temp5=mosaic_cat_index(i,1,j) + + LANDUSEF2(i,1:NLCAT-1,j)=LANDUSEF2(i,2:NLCAT,j) + mosaic_cat_index(i,1:NLCAT-1,j)=mosaic_cat_index(i,2:NLCAT,j) + + LANDUSEF2(i,NLCAT,j)=Temp4 + mosaic_cat_index(i,NLCAT,j)=Temp5 + + CALL wrf_message("IN MOSAIC_INIT") + WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j) + CALL wrf_message(message_text) + CALL wrf_message("xland < 1.5 but the dominant land use category based on our calculation is water."//& + "this is fine as long as we change our calculation so that the dominant land use category is"//& + "stwiched back to not water.") + WRITE(message_text,fmt='(a,2I6)') 'land use category has been switched, before and after values are ', & + temp5,mosaic_cat_index(i,1,j) + CALL wrf_message(message_text) + WRITE(message_text,fmt='(a,2I6)') 'new dominant and second dominant cat are ', mosaic_cat_index(i,1,j),mosaic_cat_index(i,2,j) + CALL wrf_message(message_text) + + ENDIF ! for (IVGTYP(i,j) .NE. ISWATER) + + ELSE ! for (mosaic_cat_index(I,1,J) .EQ. ISWATER) + + DO mosaic_i=2,mosaic_cat + IF (mosaic_cat_index(i,mosaic_i,j) == iswater ) THEN + Temp4=LANDUSEF2(i,mosaic_i,j) + Temp5=mosaic_cat_index(i,mosaic_i,j) + + LANDUSEF2(i,mosaic_i:NLCAT-1,j)=LANDUSEF2(i,mosaic_i+1:NLCAT,j) + mosaic_cat_index(i,mosaic_i:NLCAT-1,j)=mosaic_cat_index(i,mosaic_i+1:NLCAT,j) + + LANDUSEF2(i,NLCAT,j)=Temp4 + mosaic_cat_index(i,NLCAT,j)=Temp5 + ENDIF + ENDDO + + ENDIF ! for (mosaic_cat_index(I,1,J) .EQ. ISWATER) + + ENDIF ! for ICE == 1 + + ELSE ! FOR (XLAND(I,J).LT.1.5) + + ICE = 0 + + IF( XICE(I,J).GE. XICE_THRESHOLD ) THEN + WRITE (message_text,fmt='(a,2I6)') 'sea-ice at water point, I and J = ', i,j + CALL wrf_message(message_text) + ICE = 1 + ENDIF + + IF ((mosaic_cat_index(I,1,J) .NE. ISWATER)) THEN + + ! xland > 1.5 and the dominant land use category based on our calculation is not water + + IF (IVGTYP(i,j) .NE. ISWATER) THEN + + ! xland > 1.5 but the dominant land use category based on the geogrid calculation is not water, this must be wrong + CALL wrf_message("IN MOSAIC_INIT") + WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j) + CALL wrf_message(message_text) + CALL wrf_message("xland > 1.5 but the dominant land use category based on our calculation is not water."// & + "in addition, the dominant land use category based on the geogrid calculation is not water,"// & + "this must be wrong.") + ENDIF ! for (IVGTYP(i,j) .NE. ISWATER) + + IF (IVGTYP(i,j) .EQ. ISWATER) THEN + + ! xland > 1.5, the dominant land use category based on our calculation is not water, but based on the geogrid calculation is water, which might be due to the inconsistence between land use data and land-sea mask + + CALL wrf_message("IN MOSAIC_INIT") + WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j) + CALL wrf_message(message_text) + CALL wrf_message("xland > 1.5 but the dominant land use category based on our calculation is not water."// & + "however, the dominant land use category based on the geogrid calculation is water") + CALL wrf_message("This is fine. We do not need to do anyting because in the noaddrv, "//& + "we use xland as a criterion for whether using"// & + "mosaic or not when xland > 1.5, no mosaic will be used anyway") + + ENDIF ! for (IVGTYP(i,j) .NE. ISWATER) + + ENDIF ! for (mosaic_cat_index(I,1,J) .NE. ISWATER) + + ENDIF ! FOR (XLAND(I,J).LT.1.5) + + ENDDO + ENDDO + + !=========================================================================== + ! normalize + !=========================================================================== + + DO i = its,itf + DO j = jts,jtf + + Temp6=0 + + DO mosaic_i=1,mosaic_cat + Temp6=Temp6+LANDUSEF2(i,mosaic_i,j) + ENDDO + + if (Temp6 .LT. 1e-5) then + + Temp6 = 1e-5 + WRITE (message_text,fmt='(a,e8.1)') 'the total land surface fraction is less than ', temp6 + CALL wrf_message(message_text) + WRITE (message_text,fmt='(a,2I6,4F8.2)') 'some landusef values at i,j are ', & + i,j,landusef2(i,1,j),landusef2(i,2,j),landusef2(i,3,j),landusef2(i,4,j) + CALL wrf_message(message_text) + WRITE (message_text,fmt='(a,2I6,3I6)') 'some mosaic cat values at i,j are ', & + i,j,mosaic_cat_index(i,1,j),mosaic_cat_index(i,2,j),mosaic_cat_index(i,3,j) + CALL wrf_message(message_text) + + endif + + LANDUSEF2(i,1:mosaic_cat, j)=LANDUSEF2(i,1:mosaic_cat,j)*(1/Temp6) + + ENDDO + ENDDO + + !=========================================================================== + ! initilize the variables + !=========================================================================== + + DO i = its,itf + DO j = jts,jtf + + DO mosaic_i=1,mosaic_cat + + TSK_mosaic(i,mosaic_i,j)=TSK(i,j) + CANWAT_mosaic(i,mosaic_i,j)=CANWAT(i,j) + SNOW_mosaic(i,mosaic_i,j)=SNOW(i,j) + SNOWH_mosaic(i,mosaic_i,j)=SNOWH(i,j) + SNOWC_mosaic(i,mosaic_i,j)=SNOWC(i,j) + + ALBEDO_mosaic(i,mosaic_i,j)=ALBEDO(i,j) + ALBBCK_mosaic(i,mosaic_i,j)=ALBBCK(i,j) + EMISS_mosaic(i,mosaic_i,j)=EMISS(i,j) + EMBCK_mosaic(i,mosaic_i,j)=EMBCK(i,j) + ZNT_mosaic(i,mosaic_i,j)=Z0(i,j) + Z0_mosaic(i,mosaic_i,j)=Z0(i,j) + + DO soil_k=1,num_soil_layers + + TSLB_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=TSLB(i,soil_k,j) + SMOIS_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=SMOIS(i,soil_k,j) + SH2O_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=SH2O(i,soil_k,j) + + ENDDO + + TR_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j) + TB_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j) + TG_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j) + TC_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j) + TS_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j) + TS_RUL2D_mosaic(i,mosaic_i,j)=TSK(i,j) + QC_URB2D_mosaic(i,mosaic_i,j)=0.01 + SH_URB2D_mosaic(i,mosaic_i,j)=0 + LH_URB2D_mosaic(i,mosaic_i,j)=0 + G_URB2D_mosaic(i,mosaic_i,j)=0 + RN_URB2D_mosaic(i,mosaic_i,j)=0 + + TRL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)+0. + TRL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=0.5*(TSLB(I,1,J)+TSLB(I,2,J)) + TRL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,2,J)+0. + TRL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,2,J)+(TSLB(I,3,J)-TSLB(I,2,J))*0.29 + + TBL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)+0. + TBL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=0.5*(TSLB(I,1,J)+TSLB(I,2,J)) + TBL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,2,J)+0. + TBL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,2,J)+(TSLB(I,3,J)-TSLB(I,2,J))*0.29 + + TGL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J) + TGL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=TSLB(I,2,J) + TGL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,3,J) + TGL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,4,J) + + ENDDO + ENDDO + ENDDO + + ! simple test + + DO i = its,itf + DO j = jts,jtf + + IF ((xland(i,j).LT. 1.5 ) .AND. (mosaic_cat_index(I,1,J) .EQ. ISWATER)) THEN + CALL wrf_message("After MOSAIC_INIT") + WRITE (message_text,fmt='(a,2I6,2F8.2,2I6)') 'weird xland,xice,mosaic_cat_index and ivgtyp at I,J = ', & + i,j,xland(i,j),xice(i,j),mosaic_cat_index(I,1,J),IVGTYP(i,j) + CALL wrf_message(message_text) + ENDIF + + ENDDO + ENDDO + + ENDIF ! for not restart + +!-------------------------------- + END SUBROUTINE lsm_mosaic_init +!-------------------------------- #endif END MODULE module_sf_noahdrv diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F index a854f41f88..003c94eff8 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm.F @@ -1,16 +1,28 @@ +!================================================================================================================= MODULE module_sf_noahlsm +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. #if defined(mpas) -!MPAS specific (Laura D. Fowler): -use mpas_atmphys_constants, rhowater => rho_w -use mpas_atmphys_utilities,only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +use mpas_atmphys_constants,only: CP=>cp,R_D=>R_d,XLF=>xlf,XLV=>xlv,RHOWATER=>rho_w,STBOLT=>stbolt,KARMAN=>karman +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) #else -USE module_model_constants -#define FATAL_ERROR(M) write(0,*) M ; stop +USE module_model_constants, only : CP, R_D, XLF, XLV, RHOWATER, STBOLT, KARMAN +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) #endif -!MPAS specific end. +!ckay=KIRAN ALAPATY @ US EPA -- November 01, 2015 +! +! Tim Glotfelty@CNSU; AJ Deng@PSU +!modified for use with FASDAS +!Flux Adjusting Surface Data Assimilation System to assimilate +!surface layer and soil layers temperature and moisture using +! surfance reanalsys +!Reference: Alapaty et al., 2008: Development of the flux-adjusting surface +! data assimilation system for mesoscale models. JAMC, 47, 2331-2350 +! ! REAL, PARAMETER :: CP = 1004.5 REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & @@ -21,6 +33,7 @@ MODULE module_sf_noahlsm ! VEGETATION PARAMETERS INTEGER :: LUCATS , BARE INTEGER :: NATURAL + INTEGER :: LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 integer, PARAMETER :: NLUS=50 CHARACTER(LEN=256) LUTYPE INTEGER, DIMENSION(1:NLUS) :: NROTBL @@ -29,7 +42,8 @@ MODULE module_sf_noahlsm EMISSMINTBL, EMISSMAXTBL, & LAIMINTBL, LAIMAXTBL, & Z0MINTBL, Z0MAXTBL, & - ALBEDOMINTBL, ALBEDOMAXTBL + ALBEDOMINTBL, ALBEDOMAXTBL, & + ZTOPVTBL,ZBOTVTBL REAL :: TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA ! SOIL PARAMETERS @@ -50,11 +64,13 @@ MODULE module_sf_noahlsm CHARACTER*256 :: err_message + integer, private :: iloc, jloc +!$omp threadprivate(iloc, jloc) ! CONTAINS ! - SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C + SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C LOCAL, & !L LLANDUSE, LSOIL, & !CL LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2,SFCSPD, & !F @@ -72,6 +88,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O BETA,ETP,SSOIL, & !O FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA SNOMLT,SNCOVR, & !O RUNOFF1,RUNOFF2,RUNOFF3, & !O RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O @@ -79,7 +96,12 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C RDLAI2D,USEMONALB, & SNOTIME1, & RIBB, & - SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT) !P + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & + SFHEAD1RT, & !I + INFXS1RT,ETPND1,OPT_THCND,AOASIS & !P + ,XSDA_QFX,HFX_PHY,QFX_PHY,XQNORM & !fasdas + ,fasdas,HCPCT_FASDAS,IRRIGATION_CHANNEL ) !fasdas + ! ---------------------------------------------------------------------- ! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007 ! ---------------------------------------------------------------------- @@ -106,7 +128,6 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- ! 1. CONFIGURATION INFORMATION (C): ! ---------------------------------------------------------------------- -! ICE SEA-ICE FLAG (=1: SEA-ICE, =0: LAND (NO ICE), --1 LAND-ICE). ! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND ! 1800 SECS OR LESS) ! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES @@ -124,6 +145,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! roughness length) will be defined by three tables ! LLANDUSE (=USGS, using USGS landuse classification) ! LSOIL (=STAS, using FAO/STATSGO soil texture classification) +! OPT_THCND option for how to treat thermal conductivity ! ---------------------------------------------------------------------- ! 3. FORCING DATA (F): ! ---------------------------------------------------------------------- @@ -203,7 +225,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM ! SURFACE) ! ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1 -! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM +! SHEAT SENSIBLE HEAT FLUX (W M-2: POSITIVE, IF UPWARD FROM ! SURFACE) ! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN ! ---------------------------------------------------------------------- @@ -253,7 +275,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! SOILM TOTAL SOIL COLUMN MOISTURE CONTENT (FROZEN+UNFROZEN) (M) ! Q1 Effective mixing ratio at surface (kg kg-1), used for ! diagnosing the mixing ratio at 2 meter for coupled model -! SMAV Soil Moisture Availability for each layer, as a fraction +! SMAV Soil Moisture Availability for each layer, as a fraction ! between SMCWLT and SMCMAX. ! Documentation for SNOTIME1 and SNOABL2 ????? ! What categories of arguments do these variables fall into ???? @@ -279,6 +301,8 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! DECLARATIONS - LOGICAL AND CHARACTERS ! ---------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: IILOC, JJLOC LOGICAL, INTENT(IN):: LOCAL LOGICAL :: FRZGRA, SNOWNG CHARACTER (LEN=256), INTENT(IN):: LLANDUSE, LSOIL @@ -286,9 +310,9 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- ! 1. CONFIGURATION INFORMATION (C): ! ---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP + INTEGER,INTENT(IN) :: NSOIL,SLOPETYP,SOILTYP,VEGTYP INTEGER, INTENT(IN) :: ISURBAN - INTEGER,INTENT(INOUT):: NROOT + INTEGER,INTENT(OUT):: NROOT INTEGER KZ, K, iout ! ---------------------------------------------------------------------- @@ -296,29 +320,44 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- LOGICAL, INTENT(IN) :: RDLAI2D LOGICAL, INTENT(IN) :: USEMONALB + INTEGER, INTENT(IN) :: OPT_THCND + + REAL, INTENT(INOUT):: SFHEAD1RT,INFXS1RT, ETPND1 REAL, INTENT(IN) :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN, & Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB, & SOLDN,SOLNET,TBOT,TH2,ZLVL, & - FFROZP - REAL, INTENT(INOUT) :: EMBRD - REAL, INTENT(INOUT) :: ALBEDO + FFROZP,AOASIS + REAL, INTENT(OUT) :: EMBRD + REAL, INTENT(OUT) :: ALBEDO REAL, INTENT(INOUT):: COSZ, SOLARDIRECT,CH,CM, & CMC,SNEQV,SNCOVR,SNOWH,T1,XLAI,SHDFAC,Z0BRD, & EMISSI, ALB REAL, INTENT(INOUT):: SNOTIME1 REAL, INTENT(INOUT):: RIBB REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH - REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: ET - REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SMAV + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: ET + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: SMAV REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O, SMC, STC REAL,DIMENSION(1:NSOIL):: RTDIS, ZSOIL - REAL,INTENT(INOUT) :: ETA_KINEMATIC,BETA,DEW,DRIP,EC,EDIR,ESNOW,ETA, & + REAL,INTENT(OUT) :: ETA_KINEMATIC,BETA,DEW,DRIP,EC,EDIR,ESNOW,ETA, & ETP,FLX1,FLX2,FLX3,SHEAT,PC,RUNOFF1,RUNOFF2, & RUNOFF3,RC,RSMIN,RCQ,RCS,RCSOIL,RCT,SSOIL, & SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT, SOILM, & SOILW,FDOWN,Q1 + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL,INTENT(OUT) :: FLX4 ! UA: energy added to sensible heat + REAL,INTENT(OUT) :: FVB ! UA: frac. veg. w/snow beneath + REAL,INTENT(OUT) :: FBUR ! UA: fraction of canopy buried + REAL,INTENT(OUT) :: FGSN ! UA: ground snow cover fraction + REAL :: ZTOPV ! UA: height of canopy top + REAL :: ZBOTV ! UA: height of canopy bottom + REAL :: GAMA ! UA: = EXP(-1.* XLAI) + REAL :: FNET ! UA: + REAL :: ETPN ! UA: + REAL :: RU ! UA: + REAL :: BEXP,CFACTR,CMCMAX,CSOIL,CZIL,DF1,DF1H,DF1A,DKSAT,DWSAT, & DSOIL,DTOT,ETT,FRCSNO,FRCSOI,EPSCA,F1,FXEXP,FRZX,HS, & KDT,LVH2O,PRCP1,PSISAT,QUARTZ,R,RCH,REFKDT,RR,RGL, & @@ -340,39 +379,47 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C PARAMETER (LVH2O = 2.501E+6) PARAMETER (LSUBS = 2.83E+6) PARAMETER (R = 287.04) +! +! FASDAS +! + INTEGER, INTENT(IN ) :: fasdas + REAL, INTENT(INOUT) :: XSDA_QFX, XQNORM + REAL, INTENT(INOUT) :: HFX_PHY, QFX_PHY + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! +! IRRIGATION + REAL, OPTIONAL, INTENT(INOUT) :: IRRIGATION_CHANNEL + ! ---------------------------------------------------------------------- ! INITIALIZATION ! ---------------------------------------------------------------------- - RUNOFF1 = 0.0 - RUNOFF2 = 0.0 - RUNOFF3 = 0.0 - SNOMLT = 0.0 + ILOC = IILOC + JLOC = JJLOC -! ---------------------------------------------------------------------- -! THE VARIABLE "ICE" IS A FLAG DENOTING SEA-ICE / LAND-ICE / ICE-FREE LAND -! SEA-ICE CASE, ICE = 1 -! NON-GLACIAL LAND, ICE = 0 -! GLACIAL-ICE LAND, ICE = -1 - IF (ICE /= 0) SHDFAC = 0.0 -! ---------------------------------------------------------------------- -! SEA-ICE LAYERS ARE EQUAL THICKNESS AND SUM TO 3 METERS -! ---------------------------------------------------------------------- - IF (ICE == 1) THEN - DO KZ = 1,NSOIL - ZSOIL (KZ) = -3.* FLOAT (KZ)/ FLOAT (NSOIL) - END DO + RUNOFF1 = 0.0 + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + SNOMLT = 0.0 + + IF ( .NOT. UA_PHYS ) THEN + FLX4 = 0.0 + FVB = 0.0 + FBUR = 0.0 + FGSN = 0.0 + ENDIF ! ---------------------------------------------------------------------- ! CALCULATE DEPTH (NEGATIVE) BELOW GROUND FROM TOP SKIN SFC TO BOTTOM OF ! EACH SOIL LAYER. NOTE: SIGN OF ZSOIL IS NEGATIVE (DENOTING BELOW ! GROUND) ! ---------------------------------------------------------------------- - ELSE - ZSOIL (1) = - SLDPTH (1) - DO KZ = 2,NSOIL - ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1) - END DO - END IF + ZSOIL (1) = - SLDPTH (1) + DO KZ = 2,NSOIL + ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1) + END DO + ! ---------------------------------------------------------------------- ! NEXT IS CRUCIAL CALL TO SET THE LAND-SURFACE PARAMETERS, INCLUDING ! SOIL-TYPE AND VEG-TYPE DEPENDENT PARAMETERS. @@ -384,7 +431,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C RTDIS,SLDPTH,ZSOIL,NROOT,NSOIL,CZIL, & LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, & ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, & - LSOIL,LOCAL,LVCOEF) + LSOIL,LOCAL,LVCOEF,ZTOPV,ZBOTV) !urban IF(VEGTYP==ISURBAN)THEN @@ -453,35 +500,6 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C FRZGRA = .FALSE. ! ---------------------------------------------------------------------- -! OVER SEA-ICE OR GLACIAL-ICE, IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER -! BOUND (0.01 M FOR SEA-ICE, 0.10 M FOR GLACIAL-ICE), THEN SET AT LOWER -! BOUND -! ---------------------------------------------------------------------- -! IF SEA-ICE CASE, ASSIGN DEFAULT WATER-EQUIV SNOW ON TOP -! ---------------------------------------------------------------------- - IF (ICE == 1) THEN - ! Sea-ice case - IF ( SNEQV < 0.01 ) THEN - SNEQV = 0.01 - SNOWH = 0.05 - ENDIF - ELSE IF ( ICE == -1 ) THEN - ! Land-ice case - IF ( SNEQV < 0.10 ) THEN - SNEQV = 0.10 - SNOWH = 0.50 - ENDIF - END IF -! ---------------------------------------------------------------------- -! FOR SEA-ICE AND GLACIAL-ICE CASES, SET SMC AND SH20 VALUES = 1.0 -! ---------------------------------------------------------------------- - IF ( ICE /= 0 ) THEN - DO KZ = 1,NSOIL - SMC(KZ) = 1.0 - SH2O(KZ) = 1.0 - END DO - ENDIF -! ---------------------------------------------------------------------- ! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND ! SNOW THERMAL CONDUCTIVITY "SNCOND" (NOTE THAT CSNOW IS A FUNCTION ! SUBROUTINE) @@ -530,16 +548,6 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! UPDATE SNOW THERMAL CONDUCTIVITY ! ---------------------------------------------------------------------- CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) -! -! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3 -! for "cold permanent ice" or new "dry" snow -! - IF ( (ICE /= 0) .and. SNCOVR .GT. 0.99 ) THEN -! if soil temperature less than 268.15 K, treat as typical Antarctic/Greenland snow firn - IF ( STC(1) .LT. (TFREEZ - 5.) ) SNDENS = 0.2 - IF ( SNOWNG .AND. (T1.LT.273.) .AND. (SFCTMP.LT.273.) ) SNDENS=0.2 - ENDIF -! CALL CSNOW (SNCOND,SNDENS) ! ---------------------------------------------------------------------- @@ -549,62 +557,43 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- ELSE PRCPF = PRCP - END IF + ENDIF ! ---------------------------------------------------------------------- ! DETERMINE SNOWCOVER AND ALBEDO OVER LAND. ! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- ! IF SNOW DEPTH=0, SET SNOW FRACTION=0, ALBEDO=SNOW FREE ALBEDO. ! ---------------------------------------------------------------------- - IF (ICE == 0 .OR. ICE == -1) THEN - IF (SNEQV == 0.0) THEN - SNCOVR = 0.0 - ALBEDO = ALB - EMISSI = EMBRD - ELSE + IF (SNEQV == 0.0) THEN + SNCOVR = 0.0 + ALBEDO = ALB + EMISSI = EMBRD + IF(UA_PHYS) FGSN = 0.0 + IF(UA_PHYS) FVB = 0.0 + IF(UA_PHYS) FBUR = 0.0 + ELSE ! ---------------------------------------------------------------------- ! DETERMINE SNOW FRACTIONAL COVERAGE. ! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. ! ---------------------------------------------------------------------- - CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) -! Don't limit snow cover fraction over permanent ice kmh 2008/03/25 - if ( ICE == 0 ) then - SNCOVR = MIN(SNCOVR,0.98) - endif - CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1,ALBEDO,EMISSI, & - DT,SNOWNG,SNOTIME1,LVCOEF) - END IF -! ---------------------------------------------------------------------- -! SNOW COVER, ALBEDO OVER SEA-ICE, GLACIAL ICE -! ---------------------------------------------------------------------- - ELSE - SNCOVR = 1.0 -! -! Albedo of sea ice -! -! This value should vary seasonally. 0.65 may be good for Arctic Ocean summer bare ice -! value could be as low as 0.4 for Arctic bare ice and melt pond combo (Perovich data) -! 0.82 may be good for Arctic spring/fall sea ice (Perovich data) -! 0.81 may be good for Antarctic sea ice (Wendler et al. December cruise data) -! - ALBEDO = 0.80 -! - EMISSI = 0.98 - END IF -! ---------------------------------------------------------------------- -! THERMAL CONDUCTIVITY FOR SEA-ICE CASE, GLACIAL-ICE CASE -! ---------------------------------------------------------------------- - IF ( (ICE == 1) .or. (ICE == -1) ) THEN - DF1 = 2.2 -! -! kmh 09/03/2006 -! kmh 03/25/2008 change SNCOVR threshold to 0.97 -! - IF ( SNCOVR .GT. 0.97 ) THEN - DF1 = SNCOND + CALL SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR, & + XLAI,SHDFAC,FVB,GAMA,FBUR, & + FGSN,ZTOPV,ZBOTV,UA_PHYS) + + IF ( UA_PHYS ) then + IF(SFCTMP <= T1) THEN + RU = 0. + ELSE + RU = 100.*SHDFAC*FGSN*MIN((SFCTMP-T1)/5., 1.)*(1.-EXP(-XLAI)) + ENDIF + CH = CH/(1.+RU*CH) ENDIF -! - ELSE + + SNCOVR = MIN(SNCOVR,0.98) + + CALL ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,T1, & + ALBEDO,EMISSI,DT,SNOWNG,SNOTIME1,LVCOEF) + ENDIF ! ---------------------------------------------------------------------- ! NEXT CALCULATE THE SUBSURFACE HEAT FLUX, WHICH FIRST REQUIRES ! CALCULATION OF THE THERMAL DIFFUSIVITY. TREATMENT OF THE @@ -629,7 +618,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF ! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) ! ---------------------------------------------------------------------- - CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1)) + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban IF ( VEGTYP == ISURBAN ) DF1=3.24 @@ -648,7 +637,6 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! V.J. LINARDINI REFERENCE CITED ABOVE. NOTE THAT DTOT IS ! COMBINED DEPTH OF SNOWDEPTH AND THICKNESS OF FIRST SOIL LAYER ! ---------------------------------------------------------------------- - END IF DSOIL = - (0.5 * ZSOIL (1)) IF (SNEQV == 0.) THEN @@ -677,13 +665,6 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! MID-LAYER SOIL TEMPERATURE ! ---------------------------------------------------------------------- DF1 = DF1A * SNCOVR + DF1* (1.0- SNCOVR) - IF ( ICE /= 0 ) then - ! kmh 12/15/2005 correct for too deep snow layer - ! kmh 09/03/2006 adjust DTOT - IF ( DTOT .GT. 2.*DSOIL ) then - DTOT = 2.*DSOIL - ENDIF - ENDIF SSOIL = DF1 * (T1- STC (1) ) / DTOT END IF ! ---------------------------------------------------------------------- @@ -691,9 +672,11 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! THE PREVIOUS TIMESTEP. ! ---------------------------------------------------------------------- IF (SNCOVR > 0. ) THEN - CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH) + CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH,FBUR,FGSN,SHDMAX,UA_PHYS) ELSE Z0=Z0BRD + IF(UA_PHYS) CALL SNOWZ0 (SNCOVR,Z0,Z0BRD,SNOWH,FBUR,FGSN, & + SHDMAX,UA_PHYS) END IF ! ---------------------------------------------------------------------- ! NEXT CALL ROUTINE SFCDIF TO CALCULATE THE SFC EXCHANGE COEF (CH) FOR @@ -755,10 +738,8 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & -! -! kmh 01/09/2007 add T1,ICE,SNCOVR to call -! - DQSDT2,FLX2,EMISSI,SNEQV,T1,ICE,SNCOVR) + DQSDT2,FLX2,EMISSI,SNEQV,T1,SNCOVR,AOASIS, & + ALBEDO,SOLDN,FVB,GAMA,STC(1),ETPN,FLX4,UA_PHYS) ! ! ---------------------------------------------------------------------- ! CALL CANRES TO CALCULATE THE CANOPY RESISTANCE AND CONVERT IT INTO PC @@ -769,7 +750,7 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! FROZEN GROUND EXTENSION: TOTAL SOIL WATER "SMC" WAS REPLACED ! BY UNFROZEN SOIL WATER "SH2O" IN CALL TO CANRES BELOW ! ---------------------------------------------------------------------- - IF (SHDFAC > 0.) THEN + IF ( (SHDFAC > 0.) .AND. (XLAI > 0.) ) THEN CALL CANRES (SOLDN,CH,SFCTMP,Q2,SFCPRS,SH2O,ZSOIL,NSOIL, & SMCWLT,SMCREF,RSMIN,RC,PC,NROOT,Q2SAT,DQSDT2, & TOPT,RSMAX,RGL,HS,XLAI, & @@ -791,9 +772,12 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & SH2O,SLOPE,KDT,FRZX,PSISAT,ZSOIL, & DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & - RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, & + RUNOFF3,EDIR,EC,ET,ETT,NROOT,RTDIS, & QUARTZ,FXEXP,CSOIL, & - BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN) + BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS,IRRIGATION_CHANNEL ) !fasdas + ETA_KINEMATIC = ETA ELSE CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & @@ -804,12 +788,15 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C SNOWH,SH2O,SLOPE,KDT,FRZX,PSISAT, & ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & - ICE,RTDIS,QUARTZ,FXEXP,CSOIL, & + RTDIS,QUARTZ,FXEXP,CSOIL, & BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI, & RIBB,SOLDN, & ISURBAN, & - VEGTYP) - ETA_KINEMATIC = ESNOW + ETNS + VEGTYP, & + ETPN,FLX4,UA_PHYS, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,QFX_PHY,fasdas,HCPCT_FASDAS ) !fasdas + ETA_KINEMATIC = ESNOW + ETNS - 1000.0*DEW END IF ! Calculate effective mixing ratio at grnd level (skin) @@ -820,8 +807,18 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- ! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2) ! ---------------------------------------------------------------------- - SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + IF(UA_PHYS) SHEAT = SHEAT + FLX4 +! +! FASDAS +! + IF ( fasdas == 1 ) THEN + HFX_PHY = SHEAT + ENDIF +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2) ! ---------------------------------------------------------------------- @@ -831,8 +828,12 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ET(K) = ET(K) * LVH2O ENDDO ETT = ETT * LVH2O + + ETPND1=ETPND1 * LVH2O + ESNOW = ESNOW * LSUBS ETP = ETP*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) + IF(UA_PHYS) ETPN = ETPN*((1.-SNCOVR)*LVH2O + SNCOVR*LSUBS) IF (ETP .GT. 0.) THEN ETA = EDIR + EC + ETT + ESNOW ELSE @@ -855,52 +856,36 @@ SUBROUTINE SFLX (FFROZP,ICE,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C SSOIL = -1.0* SSOIL ! ---------------------------------------------------------------------- -! FOR THE CASE OF LAND (BUT NOT GLACIAL-ICE): +! FOR THE CASE OF LAND: ! CONVERT RUNOFF3 (INTERNAL LAYER RUNOFF FROM SUPERSAT) FROM M TO M S-1 ! AND ADD TO SUBSURFACE RUNOFF/DRAINAGE/BASEFLOW. RUNOFF2 IS ALREADY ! A RATE AT THIS POINT ! ---------------------------------------------------------------------- - IF (ICE == 0) THEN - RUNOFF3 = RUNOFF3/ DT - RUNOFF2 = RUNOFF2+ RUNOFF3 - SOILM = -1.0* SMC (1)* ZSOIL (1) - DO K = 2,NSOIL - SOILM = SOILM + SMC (K)* (ZSOIL (K -1) - ZSOIL (K)) - END DO - SOILWM = -1.0* (SMCMAX - SMCWLT)* ZSOIL (1) - SOILWW = -1.0* (SMC (1) - SMCWLT)* ZSOIL (1) -! - DO K = 1,NSOIL - SMAV(K)=(SMC(K) - SMCWLT)/(SMCMAX - SMCWLT) - END DO + RUNOFF3 = RUNOFF3/ DT + RUNOFF2 = RUNOFF2+ RUNOFF3 + SOILM = -1.0* SMC (1)* ZSOIL (1) + DO K = 2,NSOIL + SOILM = SOILM + SMC (K)* (ZSOIL (K -1) - ZSOIL (K)) + END DO + SOILWM = -1.0* (SMCMAX - SMCWLT)* ZSOIL (1) + SOILWW = -1.0* (SMC (1) - SMCWLT)* ZSOIL (1) - IF (NROOT >= 2) THEN - DO K = 2,NROOT - SOILWM = SOILWM + (SMCMAX - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) - SOILWW = SOILWW + (SMC(K) - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) - END DO - END IF - IF (SOILWM .LT. 1.E-6) THEN - SOILWM = 0.0 - SOILW = 0.0 - SOILM = 0.0 - ELSE - SOILW = SOILWW / SOILWM - END IF - ELSE -! ---------------------------------------------------------------------- -! FOR THE CASE OF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), ADD ANY -! SNOWMELT DIRECTLY TO SURFACE RUNOFF (RUNOFF1) SINCE THERE IS NO -! SOIL MEDIUM, AND THUS NO CALL TO SUBROUTINE SMFLX (FOR SOIL MOISTURE -! TENDENCY). -! ---------------------------------------------------------------------- - RUNOFF1 = SNOMLT/DT + DO K = 1,NSOIL + SMAV(K)=(SMC(K) - SMCWLT)/(SMCMAX - SMCWLT) + END DO + + IF (NROOT >= 2) THEN + DO K = 2,NROOT + SOILWM = SOILWM + (SMCMAX - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) + SOILWW = SOILWW + (SMC(K) - SMCWLT)* (ZSOIL (K -1) - ZSOIL (K)) + END DO + END IF + IF (SOILWM .LT. 1.E-6) THEN SOILWM = 0.0 SOILW = 0.0 SOILM = 0.0 - DO K = 1,NSOIL - SMAV(K)= 1.0 - END DO + ELSE + SOILW = SOILWW / SOILWM END IF ! ---------------------------------------------------------------------- @@ -932,7 +917,7 @@ SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,SHDFAC,SHDMIN,SNCOVR,TSNOW,ALBEDO,EMISSI, REAL, INTENT(IN) :: DT LOGICAL, INTENT(IN) :: SNOWNG REAL, INTENT(INOUT):: SNOTIME1 - REAL, INTENT(INOUT) :: ALBEDO, EMISSI + REAL, INTENT(OUT) :: ALBEDO, EMISSI REAL :: SNOALB2 REAL :: TM,SNOALB1 REAL, INTENT(IN) :: LVCOEF @@ -1073,7 +1058,7 @@ SUBROUTINE CANRES (SOLAR,CH,SFCTMP,Q2,SFCPRS,SMC,ZSOIL,NSOIL, & SFCPRS,SFCTMP,SMCREF,SMCWLT, SOLAR,TOPT,XLAI, & EMISSI REAL,DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL - REAL, INTENT(INOUT):: PC,RC,RCQ,RCS,RCSOIL,RCT + REAL, INTENT(OUT):: PC,RC,RCQ,RCS,RCSOIL,RCT REAL :: DELTA,FF,GX,P,RR REAL, DIMENSION(1:NSOIL) :: PART REAL, PARAMETER :: SLV = 2.501000E6 @@ -1174,7 +1159,7 @@ SUBROUTINE CSNOW (SNCOND,DSNOW) ! ---------------------------------------------------------------------- IMPLICIT NONE REAL, INTENT(IN) :: DSNOW - REAL, INTENT(INOUT):: SNCOND + REAL, INTENT(OUT):: SNCOND REAL :: C REAL, PARAMETER :: UNIT = 0.11631 @@ -1205,7 +1190,6 @@ SUBROUTINE CSNOW (SNCOND,DSNOW) ! ---------------------------------------------------------------------- END SUBROUTINE CSNOW ! ---------------------------------------------------------------------- - SUBROUTINE DEVAP (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) @@ -1218,7 +1202,7 @@ SUBROUTINE DEVAP (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & IMPLICIT NONE REAL, INTENT(IN) :: ETP1,SMC,BEXP,DKSAT,DWSAT,FXEXP, & SHDFAC,SMCDRY,SMCMAX,ZSOIL,SMCREF,SMCWLT - REAL, INTENT(INOUT):: EDIR + REAL, INTENT(OUT):: EDIR REAL :: FX, SRATIO @@ -1246,6 +1230,98 @@ SUBROUTINE DEVAP (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & ! ---------------------------------------------------------------------- END SUBROUTINE DEVAP + + SUBROUTINE DEVAP_hydro (EDIR,ETP1,SMC,ZSOIL,SHDFAC,SMCMAX,BEXP, & + DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP, & + SFHEAD1RT,ETPND1,DT) + +! ---------------------------------------------------------------------- +! SUBROUTINE DEVAP +! FUNCTION DEVAP +! ---------------------------------------------------------------------- +! CALCULATE DIRECT SOIL EVAPORATION +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: ETP1,SMC,BEXP,DKSAT,DWSAT,FXEXP, & + SHDFAC,SMCDRY,SMCMAX,ZSOIL,SMCREF,SMCWLT + REAL, INTENT(OUT):: EDIR + REAL :: FX, SRATIO + + REAL, INTENT(INOUT) :: SFHEAD1RT,ETPND1 + REAL, INTENT(IN ) :: DT + REAL :: EDIRTMP + + + +! ---------------------------------------------------------------------- +! DIRECT EVAP A FUNCTION OF RELATIVE SOIL MOISTURE AVAILABILITY, LINEAR +! WHEN FXEXP=1. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO > 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + +!DJG NDHMS/WRF-Hydro edits... Adjustment for ponded surface water : Reduce ETP1 + EDIRTMP = 0. + ETPND1 = 0. + +!DJG NDHMS/WRF-Hydro edits... Calc Max Potential Dir Evap. (ETP1 units: }=m/s) + +!DJG NDHMS/WRF-Hydro...currently set ponded water evap to 0.0 until further notice...11/5/2012 +!EDIRTMP = ( 1.0- SHDFAC ) * ETP1 + +! Convert all units to (m) +! Convert EDIRTMP from (kg m{-2} s{-1}=m/s) to (m) ... + EDIRTMP = EDIRTMP * DT + +!DJG NDHMS/WRF-Hydro edits... Convert SFHEAD from (mm) to (m) ... + SFHEAD1RT=SFHEAD1RT * 0.001 + + + +!DJG NDHMS/WRF-Hydro edits... Calculate ETPND as reduction in EDIR(TMP)... + IF (EDIRTMP > 0.) THEN + IF ( EDIRTMP > SFHEAD1RT ) THEN + ETPND1 = SFHEAD1RT + SFHEAD1RT=0. + EDIRTMP = EDIRTMP - ETPND1 + ELSE + ETPND1 = EDIRTMP + EDIRTMP = 0. + SFHEAD1RT = SFHEAD1RT - ETPND1 + END IF + END IF + +!DJG NDHMS/WRF-Hydro edits... Convert SFHEAD units back to (mm) + IF ( SFHEAD1RT /= 0.) SFHEAD1RT=SFHEAD1RT * 1000. + +!DJG NDHMS/WRF-Hydro edits...Convert ETPND and EDIRTMP back to (mm/s=kg m{-2} s{-1}) + ETPND1 = ETPND1 / DT + EDIRTMP = EDIRTMP / DT +!DEBUG print *, "After DEVAP...SFCHEAD+ETPND1",SFHEAD1RT+ETPND1*DT + + +! ---------------------------------------------------------------------- +! ALLOW FOR THE DIRECT-EVAP-REDUCING EFFECT OF SHADE +! ---------------------------------------------------------------------- +!DJG NDHMS/WRF-Hydro edits... +! EDIR = FX * ( 1.0- SHDFAC ) * ETP1 + EDIR = FX * EDIRTMP + + + + +! ---------------------------------------------------------------------- + END SUBROUTINE DEVAP_hydro ! ---------------------------------------------------------------------- SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & @@ -1253,7 +1329,8 @@ SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & SMCREF,SHDFAC,CMCMAX, & SMCDRY,CFACTR, & - EDIR,EC,ET,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + EDIR,EC,ET,ETT,SFCTMP,Q2,NROOT,RTDIS,FXEXP, & + SFHEAD1RT,ETPND1) ! ---------------------------------------------------------------------- ! SUBROUTINE EVAPO @@ -1268,12 +1345,14 @@ SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & INTEGER, INTENT(IN) :: NSOIL, NROOT INTEGER :: I,K REAL, INTENT(IN) :: BEXP, CFACTR,CMC,CMCMAX,DKSAT, & - DT,DWSAT,ETP1,FXEXP,PC,Q2,SFCTMP, & + DT,DWSAT,ETP1,FXEXP,PC,Q2,SFCTMP, & SHDFAC,SMCDRY,SMCMAX,SMCREF,SMCWLT - REAL, INTENT(INOUT) :: EC,EDIR,ETA1,ETT + REAL, INTENT(OUT) :: EC,EDIR,ETA1,ETT REAL :: CMC2MS REAL,DIMENSION(1:NSOIL), INTENT(IN) :: RTDIS, SMC, SH2O, ZSOIL - REAL,DIMENSION(1:NSOIL), INTENT(INOUT) :: ET + REAL,DIMENSION(1:NSOIL), INTENT(OUT) :: ET + + REAL, INTENT(INOUT) :: SFHEAD1RT,ETPND1 ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE IF THE POTENTIAL EVAPOTRANSPIRATION IS @@ -1293,8 +1372,21 @@ SUBROUTINE EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & ! ---------------------------------------------------------------------- IF (ETP1 > 0.0) THEN IF (SHDFAC < 1.) THEN +#ifdef WRF_HYDRO +! CALL DEVAP_hydro (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & +! BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP, & +! SFHEAD1RT,ETPND1,DT) +!DJG Reduce ETP1 by EDIR & ETPND1... +! ETP1=ETP1-EDIR-ETPND1 + +! following is the temparay setting ... CALL DEVAP (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) +! ETP1=ETP1-EDIR +#else + CALL DEVAP (EDIR,ETP1,SMC (1),ZSOIL (1),SHDFAC,SMCMAX, & + BEXP,DKSAT,DWSAT,SMCDRY,SMCREF,SMCWLT,FXEXP) +#endif END IF ! ---------------------------------------------------------------------- ! INITIALIZE PLANT TOTAL TRANSPIRATION, RETRIEVE PLANT TRANSPIRATION, @@ -1336,7 +1428,7 @@ END SUBROUTINE EVAPO SUBROUTINE FAC2MIT(SMCMAX,FLIMIT) IMPLICIT NONE REAL, INTENT(IN) :: SMCMAX - REAL, INTENT(INOUT) :: FLIMIT + REAL, INTENT(OUT) :: FLIMIT FLIMIT = 0.90 @@ -1389,7 +1481,7 @@ SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O,SMCMAX,BEXP,PSIS) ! ---------------------------------------------------------------------- IMPLICIT NONE REAL, INTENT(IN) :: BEXP,PSIS,SH2O,SMC,SMCMAX,TKELV - REAL, INTENT(INOUT) :: FREE + REAL, INTENT(OUT) :: FREE REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK INTEGER :: NLOG,KCOUNT ! PARAMETER(CK = 0.0) @@ -1498,8 +1590,9 @@ END SUBROUTINE FRH2O ! ---------------------------------------------------------------------- SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & - TBOT,ZBOT,PSISAT,SH2O,DT,BEXP, & - F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN) + TBOT,ZBOT,PSISAT,SH2O,DT,BEXP,SOILTYP,OPT_THCND, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN & + ,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE HRT @@ -1510,7 +1603,8 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! ---------------------------------------------------------------------- IMPLICIT NONE LOGICAL :: ITAVG - INTEGER, INTENT(IN) :: NSOIL, VEGTYP + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NSOIL, VEGTYP, SOILTYP INTEGER, INTENT(IN) :: ISURBAN INTEGER :: I, K @@ -1518,14 +1612,21 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & SMCMAX ,TBOT,YY,ZZ1, ZBOT REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,STC,ZSOIL REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SH2O - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTS - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI,CI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI REAL :: DDZ, DDZ2, DENOM, DF1N, DF1K, DTSDZ, & DTSDZ2,HCPCT,QTOT,SSOIL,SICE,TAVG,TBK, & TBK1,TSNSR,TSURF,CSOIL_LOC REAL, PARAMETER :: T0 = 273.15, CAIR = 1004.0, CICE = 2.106E6,& CH2O = 4.2E6 +! +! FASDAS +! + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! !urban IF( VEGTYP == ISURBAN ) then @@ -1546,7 +1647,13 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & HCPCT = SH2O (1)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC (1))& * CAIR & + ( SMC (1) - SH2O (1) )* CICE - +! +! FASDAS +! + HCPCT_FASDAS = HCPCT +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER ! ---------------------------------------------------------------------- @@ -1647,7 +1754,7 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! ---------------------------------------------------------------------- ! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER ! ---------------------------------------------------------------------- - CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K)) + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban IF ( VEGTYP == ISURBAN ) DF1N = 3.24 @@ -1679,7 +1786,7 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! ---------------------------------------------------------------------- ! CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER. ! ---------------------------------------------------------------------- - CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K)) + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban @@ -1747,172 +1854,6 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & END SUBROUTINE HRT ! ---------------------------------------------------------------------- - SUBROUTINE HRTICE (RHSTS,STC,TBOT,ICE,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) - -! ---------------------------------------------------------------------- -! SUBROUTINE HRTICE -! ---------------------------------------------------------------------- -! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL -! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE (ICE=1) OR GLACIAL -! ICE (ICE=-1). COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE -! TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. -! -! (NOTE: THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT -! NOT FOR NON-GLACIAL LAND (ICE = 0). -! ---------------------------------------------------------------------- - IMPLICIT NONE - - - INTEGER, INTENT(IN) :: NSOIL - INTEGER :: K - - REAL, INTENT(IN) :: DF1,YY,ZZ1 - REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI, BI,CI - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STC, ZSOIL - REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS - REAL, INTENT(IN) :: TBOT - INTEGER, INTENT(IN) :: ICE - REAL :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL, & - ZBOT - REAL :: HCPCT - REAL :: DF1K - REAL :: DF1N - REAL :: ZMD - -! ---------------------------------------------------------------------- -! SET A NOMINAL UNIVERSAL VALUE OF THE SEA-ICE SPECIFIC HEAT CAPACITY, -! HCPCT = 1880.0*917.0. -! ---------------------------------------------------------------------- - IF ( ICE == 1 ) THEN - ! Sea-ice values - HCPCT = 1.72396E+6 - ELSEIF (ICE == -1) THEN -! SET A NOMINAL UNIVERSAL VALUE OF GLACIAL-ICE SPECIFIC HEAT CAPACITY, -! HCPCT = 2100.0*900.0 = 1.89000E+6 (SOURCE: BOB GRUMBINE, 2005) -! TBOT PASSED IN AS ARGUMENT, VALUE FROM GLOBAL DATA SET - ! - ! A least-squares fit for the four points provided by - ! Keith Hines for the Yen (1981) values for Antarctic - ! snow firn. - ! - HCPCT = 1.E6 * (0.8194 - 0.1309*0.5*ZSOIL(1)) - DF1K = DF1 - ENDIF - -! ---------------------------------------------------------------------- -! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE -! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2. -! ---------------------------------------------------------------------- -! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE -! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE -! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK -! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER -! ---------------------------------------------------------------------- - IF (ICE == 1) THEN - ZBOT = ZSOIL (NSOIL) - ELSE IF (ICE == -1) THEN - ZBOT = -25.0 - ENDIF - DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) - AI (1) = 0.0 - CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) - -! ---------------------------------------------------------------------- -! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. -! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC -! RHSTS FOR THE TOP SOIL LAYER. -! ---------------------------------------------------------------------- - BI (1) = - CI (1) + DF1/ (0.5 * ZSOIL (1) * ZSOIL (1) * HCPCT * & - ZZ1) - DTSDZ = ( STC (1) - STC (2) ) / ( -0.5 * ZSOIL (2) ) - SSOIL = DF1 * ( STC (1) - YY ) / ( 0.5 * ZSOIL (1) * ZZ1 ) - -! ---------------------------------------------------------------------- -! INITIALIZE DDZ2 -! ---------------------------------------------------------------------- - RHSTS (1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL (1) * HCPCT ) - -! ---------------------------------------------------------------------- -! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS -! ---------------------------------------------------------------------- - DDZ2 = 0.0 - DF1K = DF1 - DF1N = DF1 - DO K = 2,NSOIL - - IF ( ICE == -1 ) THEN - ZMD = 0.5 * (ZSOIL(K)+ZSOIL(K-1)) - ! For the land-ice case -! kmh 09/03/2006 use Yen (1981)'s values for Antarctic snow firn -! IF ( K .eq. 2 ) HCPCT = 0.855108E6 -! IF ( K .eq. 3 ) HCPCT = 0.922906E6 -! IF ( K .eq. 4 ) HCPCT = 1.009986E6 - - ! Least squares fit to the four points supplied by Keith Hines - ! from Yen (1981) for Antarctic snow firn. Not optimal, but - ! probably better than just a constant. - HCPCT = 1.E6 * ( 0.8194 - 0.1309*ZMD ) - -! IF ( K .eq. 2 ) DF1N = 0.345356 -! IF ( K .eq. 3 ) DF1N = 0.398777 -! IF ( K .eq. 4 ) DF1N = 0.472653 - - ! Least squares fit to the three points supplied by Keith Hines - ! from Yen (1981) for Antarctic snow firn. Not optimal, but - ! probably better than just a constant. - DF1N = 0.32333 - ( 0.10073 * ZMD ) - ENDIF -! ---------------------------------------------------------------------- -! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. -! ---------------------------------------------------------------------- - IF (K /= NSOIL) THEN - DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) - -! ---------------------------------------------------------------------- -! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. -! ---------------------------------------------------------------------- - DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM - DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) - CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K))*HCPCT) - -! ---------------------------------------------------------------------- -! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. -! ---------------------------------------------------------------------- - ELSE - -! ---------------------------------------------------------------------- -! SET MATRIX COEF, CI TO ZERO. -! ---------------------------------------------------------------------- - DTSDZ2 = (STC (K) - TBOT)/ (.5 * (ZSOIL (K -1) + ZSOIL (K)) & - - ZBOT) - CI (K) = 0. -! ---------------------------------------------------------------------- -! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. -! ---------------------------------------------------------------------- - END IF - DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT - -! ---------------------------------------------------------------------- -! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. -! ---------------------------------------------------------------------- - RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM - AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) - -! ---------------------------------------------------------------------- -! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. -! ---------------------------------------------------------------------- - BI (K) = - (AI (K) + CI (K)) - DF1K = DF1N - DTSDZ = DTSDZ2 - DDZ = DDZ2 - END DO -! ---------------------------------------------------------------------- - END SUBROUTINE HRTICE -! ---------------------------------------------------------------------- - SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) ! ---------------------------------------------------------------------- @@ -1925,7 +1866,7 @@ SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) INTEGER :: K REAL, DIMENSION(1:NSOIL), INTENT(IN):: STCIN - REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: STCOUT REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI,BI,CI REAL, DIMENSION(1:NSOIL) :: RHSTSin @@ -1971,9 +1912,12 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & STC,EPSCA,BEXP,PC,RCH,RR,CFACTR, & SH2O,SLOPE,KDT,FRZFACT,PSISAT,ZSOIL, & DKSAT,DWSAT,TBOT,ZBOT,RUNOFF1,RUNOFF2, & - RUNOFF3,EDIR,EC,ET,ETT,NROOT,ICE,RTDIS, & + RUNOFF3,EDIR,EC,ET,ETT,NROOT,RTDIS, & QUARTZ,FXEXP,CSOIL, & - BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN) + BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS & + ,IRRIGATION_CHANNEL ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE NOPAC @@ -1984,7 +1928,8 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: ICE, NROOT,NSOIL,VEGTYP + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NROOT,NSOIL,VEGTYP,SOILTYP INTEGER, INTENT(IN) :: ISURBAN INTEGER :: K @@ -1994,15 +1939,29 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & SHDFAC,SLOPE,SMCDRY,SMCMAX,SMCREF,SMCWLT, & T24,TBOT,TH2,ZBOT,EMISSI REAL, INTENT(INOUT) :: CMC,BETA,T1 - REAL, INTENT(INOUT) :: DEW,DRIP,EC,EDIR,ETA,ETT,FLX1,FLX3, & + REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR,ETA,ETT,FLX1,FLX3, & RUNOFF1,RUNOFF2,RUNOFF3,SSOIL +!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT,ETPND1 + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL - REAL, DIMENSION(1:NSOIL),INTENT(INOUT) :: ET + REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC REAL, DIMENSION(1:NSOIL) :: ET1 REAL :: EC1,EDIR1,ETT1,DF1,ETA1,ETP1,PRCP1,YY, & YYNUM,ZZ1 - +! +! FASDAS +! + REAL :: XSDA_QFX, QFX_PHY, XQNORM + INTEGER :: fasdas + REAL , DIMENSION(1:NSOIL) :: EFT(NSOIL), wetty(1:NSOIL) + REAL :: EFDIR, EFC, EALL_now + REAL, INTENT( OUT) :: HCPCT_FASDAS + REAL, INTENT(IN),OPTIONAL :: IRRIGATION_CHANNEL +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE: ! CONVERT ETP Fnd PRCP FROM KG M-2 S-1 TO M S-1 AND INITIALIZE DEW. @@ -2013,6 +1972,13 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- ! INITIALIZE EVAP TERMS. ! ---------------------------------------------------------------------- +! +! FASDAS +! + QFX_PHY = 0.0 +! +! END FASDAS +! EDIR = 0. EDIR1 = 0. EC1 = 0. @@ -2020,24 +1986,75 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & DO K = 1,NSOIL ET(K) = 0. ET1(K) = 0. +! +! FASDAS +! + wetty(K) = 1.0 +! +! END FASDAS +! END DO ETT = 0. ETT1 = 0. +!DJG NDHMS/WRF-Hydro edit... + ETPND1 = 0. + + IF (ETP > 0.0) THEN CALL EVAPO (ETA1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & SH2O, & SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & SMCREF,SHDFAC,CMCMAX, & SMCDRY,CFACTR, & - EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP) + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP, & + SFHEAD1RT,ETPND1 ) +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET1(K) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + IF(SMC(K).GE.SMCREF.and.XSDA_QFX.gt.0.0) wetty(K)=0.0 + END DO + QFX_PHY = EDIR1+EC1+QFX_PHY ! m/s + EALL_now = QFX_PHY ! m/s + QFX_PHY = QFX_PHY*1000.0 ! Kg/m2/s + + if(EALL_now.ne.0.0) then + EFDIR = (EDIR1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFDIR = EFDIR * wetty(1) + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + EDIR1 = EDIR1 + EFDIR ! new value + + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + EC1 = EC1 + EFC ! new value + + + DO K=1,NSOIL + EFT(K) = (ET1(K)/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFT(K) = EFT(K) * wetty(K) + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + ET1(K) = ET1(K) + EFT(K) ! new value + END DO + + + END IF ! for non-zero eall_now + ELSE + QFX_PHY = 0.0 + ENDIF +! +! END FASDAS +! CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & SH2O,SLOPE,KDT,FRZFACT, & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & SHDFAC,CMCMAX, & RUNOFF1,RUNOFF2,RUNOFF3, & EDIR1,EC1,ET1, & - DRIP) + DRIP, SFHEAD1RT,INFXS1RT,IRRIGATION_CHANNEL) ! ---------------------------------------------------------------------- ! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1. @@ -2057,13 +2074,50 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- PRCP1 = PRCP1+ DEW +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET1(K) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + IF(SMC(K).GE.SMCREF.and.XSDA_QFX.gt.0.0) wetty(K)=0.0 + END DO + QFX_PHY = EDIR1+EC1+QFX_PHY ! m/s + EALL_now = QFX_PHY ! m/s + QFX_PHY = QFX_PHY*1000.0 ! Kg/m2/s + + IF(EALL_now.ne.0.0) then + EFDIR = (EDIR1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFDIR = EFDIR * wetty(1) + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + EDIR1 = EDIR1 + EFDIR ! new value + + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + EC1 = EC1+ EFC ! new value + + DO K=1,NSOIL + EFT(K) = (ET1(K)/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFT(K) = EFT(K) * wetty(K) + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + ET1(K) = ET1(K) + EFT(K) ! new value + END DO + + END IF ! for non-zero eall_now + ELSE + QFX_PHY = 0.0 + ENDIF +! +! END FASDAS +! CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & SH2O,SLOPE,KDT,FRZFACT, & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & SHDFAC,CMCMAX, & RUNOFF1,RUNOFF2,RUNOFF3, & EDIR1,EC1,ET1, & - DRIP) + DRIP, SFHEAD1RT,INFXS1RT,IRRIGATION_CHANNEL) ! ---------------------------------------------------------------------- ! CONVERT MODELED EVAPOTRANSPIRATION FROM 'M S-1' TO 'KG M-2 S-1'. @@ -2101,7 +2155,7 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. ! ---------------------------------------------------------------------- - CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1)) + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban IF ( VEGTYP == ISURBAN ) DF1=3.24 @@ -2125,9 +2179,10 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ZZ1 = DF1 / ( -0.5 * ZSOIL (1) * RCH * RR ) + 1.0 !urban - CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & - TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & - QUARTZ,CSOIL,VEGTYP,ISURBAN) + CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE @@ -2143,7 +2198,8 @@ END SUBROUTINE NOPAC SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & - & DQSDT2,FLX2,EMISSI_IN,SNEQV,T1,ICE,SNCOVR) + & DQSDT2,FLX2,EMISSI_IN,SNEQV,T1,SNCOVR,AOASIS, & + ALBEDO,SOLDN,FVB,GAMA,STC1,ETPN,FLX4,UA_PHYS) ! ---------------------------------------------------------------------- ! SUBROUTINE PENMAN @@ -2156,18 +2212,19 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP, & Q2, Q2SAT,SSOIL, SFCPRS, SFCTMP, & - T2V, TH2,EMISSI_IN,SNEQV + T2V, TH2,EMISSI_IN,SNEQV,AOASIS REAL, INTENT(IN) :: T1 , SNCOVR + REAL, INTENT(IN) :: ALBEDO,SOLDN,FVB,GAMA,STC1 + LOGICAL, INTENT(IN) :: UA_PHYS ! -! kmh 09/13/2006 - INTEGER, INTENT(IN) :: ICE -! kmh 09/03/2006 -! - REAL, INTENT(INOUT) :: EPSCA,ETP,FLX2,RCH,RR,T24 + REAL, INTENT(OUT) :: EPSCA,ETP,FLX2,RCH,RR,T24 + REAL, INTENT(OUT) :: FLX4,ETPN REAL :: A, DELTA, FNET,RAD,RHO,EMISSI,ELCP1,LVS + REAL :: TOTABS,UCABS,SIGNCK,FNETN,RADN,EPSCAN REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6,CP = 1004.6 REAL, PARAMETER :: LSUBS = 2.83E+6 + REAL, PARAMETER :: ALGDSN = 0.5, ALVGSN = 0.13 ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE: @@ -2176,18 +2233,8 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & ! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. ! ---------------------------------------------------------------------- EMISSI=EMISSI_IN - IF (ICE==0) THEN - ELCP1 = (1.0-SNCOVR)*ELCP + SNCOVR*ELCP*LSUBS/LSUBC - LVS = (1.0-SNCOVR)*LSUBC + SNCOVR*LSUBS - ELSE - IF ( T1 > 273.15 ) THEN - ELCP1=ELCP - LVS=LSUBC - ELSE - ELCP1 = ELCP*LSUBS/LSUBC - LVS = LSUBS - ENDIF - ENDIF + ELCP1 = (1.0-SNCOVR)*ELCP + SNCOVR*ELCP*LSUBS/LSUBC + LVS = (1.0-SNCOVR)*LSUBC + SNCOVR*LSUBS FLX2 = 0.0 ! DELTA = ELCP * DQSDT2 @@ -2214,9 +2261,39 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & ! ---------------------------------------------------------------------- ! FNET = FDOWN - SIGMA * T24- SSOIL FNET = FDOWN - EMISSI*SIGMA * T24- SSOIL + + FLX4 = 0.0 + IF(UA_PHYS) THEN + IF(SNEQV > 0. .AND. FNET > 0. .AND. SOLDN > 0. ) THEN + TOTABS = (1.-ALBEDO)*SOLDN*FVB ! solar radiation absorbed + ! by vegetated fraction + UCABS = MIN(TOTABS,((1.0-ALGDSN)*(1.0-ALVGSN)*SOLDN*GAMA)*FVB) +! print*,'penman',UCABS,TOTABS,SOLDN,GAMA,FVB +! UCABS = MIN(TOTABS,(0.44*SOLDN*GAMA)*FVB) + ! UCABS -> solar radiation + ! absorbed under canopy + FLX4 = MIN(TOTABS - UCABS, MIN(250., 0.5*(1.-ALBEDO)*SOLDN)) + ENDIF + + SIGNCK = (STC1-273.15)*(SFCTMP-273.15) + + IF(FLX4 > 0. .AND. (SIGNCK <= 0. .OR. STC1 < 273.15)) THEN + IF(FNET >= FLX4) THEN + FNETN = FNET - FLX4 + ELSE + FLX4 = FNET + FNETN = 0. + ENDIF + ELSE + FLX4 = 0.0 + FNETN = 0. + ENDIF + ENDIF + IF (FRZGRA) THEN FLX2 = - LSUBF * PRCP FNET = FNET - FLX2 + IF(UA_PHYS) FNETN = FNETN - FLX2 ! ---------------------------------------------------------------------- ! FINISH PENMAN EQUATION CALCULATIONS. ! ---------------------------------------------------------------------- @@ -2225,9 +2302,16 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & ! A = ELCP * (Q2SAT - Q2) A = ELCP1 * (Q2SAT - Q2) EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) +! Fei-Mike + IF (EPSCA>0.) EPSCA = EPSCA * AOASIS ! ETP = EPSCA * RCH / LSUBC ETP = EPSCA * RCH / LVS + IF(UA_PHYS) THEN + RADN = FNETN / RCH + TH2- SFCTMP + EPSCAN = (A * RR + RADN * DELTA) / (DELTA + RR) + ETPN = EPSCAN * RCH / LVS + END IF ! ---------------------------------------------------------------------- END SUBROUTINE PENMAN ! ---------------------------------------------------------------------- @@ -2240,7 +2324,7 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & RTDIS,SLDPTH,ZSOIL, NROOT,NSOIL,CZIL, & LAIMIN, LAIMAX, EMISSMIN, EMISSMAX, ALBEDOMIN, & ALBEDOMAX, Z0MIN, Z0MAX, CSOIL, PTU, LLANDUSE, & - LSOIL, LOCAL,LVCOEF) + LSOIL, LOCAL,LVCOEF,ZTOPV,ZBOTV) IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -2323,40 +2407,41 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & ! Veg parameters INTEGER, INTENT(IN) :: VEGTYP - INTEGER, INTENT(INOUT) :: NROOT - REAL, INTENT(INOUT) :: HS,RSMIN,RGL,SHDFAC,SNUP, & + INTEGER, INTENT(OUT) :: NROOT + REAL, INTENT(INOUT) :: SHDFAC + REAL, INTENT(OUT) :: HS,RSMIN,RGL,SNUP, & CMCMAX,RSMAX,TOPT, & EMISSMIN, EMISSMAX, & LAIMIN, LAIMAX, & Z0MIN, Z0MAX, & - ALBEDOMIN, ALBEDOMAX + ALBEDOMIN, ALBEDOMAX, ZTOPV, ZBOTV ! Soil parameters INTEGER, INTENT(IN) :: SOILTYP - REAL, INTENT(INOUT) :: BEXP,DKSAT,DWSAT,F1,QUARTZ,SMCDRY, & + REAL, INTENT(OUT) :: BEXP,DKSAT,DWSAT,F1,QUARTZ,SMCDRY, & SMCMAX,SMCREF,SMCWLT,PSISAT ! General parameters INTEGER, INTENT(IN) :: SLOPETYP,NSOIL INTEGER :: I - REAL, INTENT(INOUT) :: SLOPE,CZIL,SBETA,FXEXP, & + REAL, INTENT(OUT) :: SLOPE,CZIL,SBETA,FXEXP, & CSOIL,SALP,FRZX,KDT,CFACTR, & ZBOT,REFKDT,PTU - REAL, INTENT(INOUT) :: LVCOEF + REAL, INTENT(OUT) :: LVCOEF REAL,DIMENSION(1:NSOIL),INTENT(IN) :: SLDPTH,ZSOIL - REAL,DIMENSION(1:NSOIL),INTENT(INOUT):: RTDIS + REAL,DIMENSION(1:NSOIL),INTENT(OUT):: RTDIS REAL :: FRZFACT,FRZK,REFDK ! SAVE ! ---------------------------------------------------------------------- ! IF (SOILTYP .gt. SLCATS) THEN - CALL physics_error_fatal ( 'Warning: too many input soil types' ) + FATAL_ERROR( 'Warning: too many input soil types' ) END IF IF (VEGTYP .gt. LUCATS) THEN - CALL physics_error_fatal ( 'Warning: too many input landuse types' ) + FATAL_ERROR( 'Warning: too many input landuse types' ) END IF IF (SLOPETYP .gt. SLPCATS) THEN - CALL physics_error_fatal ( 'Warning: too many input slope types' ) + FATAL_ERROR( 'Warning: too many input slope types' ) END IF ! ---------------------------------------------------------------------- @@ -2416,6 +2501,8 @@ SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,CFACTR,CMCMAX,RSMAX, & Z0MAX = Z0MAXTBL (VEGTYP) ALBEDOMIN = ALBEDOMINTBL (VEGTYP) ALBEDOMAX = ALBEDOMAXTBL (VEGTYP) + ZTOPV = ZTOPVTBL (VEGTYP) + ZBOTV = ZBOTVTBL (VEGTYP) IF (VEGTYP .eq. BARE) SHDFAC = 0.0 IF (NROOT .gt. NSOIL) THEN @@ -2479,7 +2566,6 @@ SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) REAL, DIMENSION(1:NSOIL), INTENT(IN):: A, B, D REAL, DIMENSION(1:NSOIL),INTENT(INOUT):: C,P,DELTA - ! ---------------------------------------------------------------------- ! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER ! ---------------------------------------------------------------------- @@ -2515,9 +2601,10 @@ END SUBROUTINE ROSR12 ! ---------------------------------------------------------------------- - SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & - TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & - QUARTZ,CSOIL,VEGTYP,ISURBAN) + SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) ! fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE SHFLX @@ -2528,45 +2615,43 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: ICE, NSOIL, VEGTYP, ISURBAN + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NSOIL, VEGTYP, ISURBAN, SOILTYP INTEGER :: I REAL, INTENT(IN) :: BEXP,CSOIL,DF1,DT,F1,PSISAT,QUARTZ, & SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1 REAL, INTENT(INOUT) :: T1 - REAL, INTENT(INOUT) :: SSOIL + REAL, INTENT(OUT) :: SSOIL REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS REAL, PARAMETER :: T0 = 273.15 +! +! FASDAS +! + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN ! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! SEA-ICE CASE, GLACIAL ICE CASE -! ---------------------------------------------------------------------- - IF ( ICE /= 0 ) THEN - - CALL HRTICE (RHSTS,STC,TBOT,ICE,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + ! Land case - CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + ZBOT,PSISAT,SH2O,DT,BEXP,SOILTYP,OPT_THCND, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN & + ,HCPCT_FASDAS ) !fasdas -! ---------------------------------------------------------------------- -! LAND-MASS CASE -! ---------------------------------------------------------------------- - ELSE - CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & - ZBOT,PSISAT,SH2O,DT, & - BEXP,F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN) + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) - CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) - END IF DO I = 1,NSOIL STC (I) = STCF (I) - END DO + ENDDO ! ---------------------------------------------------------------------- ! IN THE NO SNOWPACK CASE (VIA ROUTINE NOPAC BRANCH,) UPDATE THE GRND @@ -2591,7 +2676,8 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & & SHDFAC,CMCMAX, & & RUNOFF1,RUNOFF2,RUNOFF3, & & EDIR,EC,ET, & - & DRIP) + & DRIP, SFHEAD1RT,INFXS1RT, & + IRRIGATION_CHANNEL ) ! ---------------------------------------------------------------------- ! SUBROUTINE SMFLX @@ -2609,15 +2695,17 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & REAL, INTENT(IN) :: BEXP, CMCMAX, DKSAT,DWSAT, DT, EC, EDIR, & KDT, PRCP1, SHDFAC, SLOPE, SMCMAX, SMCWLT - REAL, INTENT(INOUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3 + REAL, INTENT(OUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3 REAL, INTENT(INOUT) :: CMC REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET,ZSOIL REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: SMC, SH2O REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT, & - SICE, SH2OA, SH2OFG + SICE, SH2OA, SH2OFG, SH2OIN REAL :: DUMMY, EXCESS,FRZFACT,PCPDRP,RHSCT,TRHSCT REAL :: FAC2 REAL :: FLIMIT + REAL, INTENT(IN),OPTIONAL :: IRRIGATION_CHANNEL + REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE. @@ -2643,7 +2731,9 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! ---------------------------------------------------------------------- IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX PCPDRP = (1. - SHDFAC) * PRCP1+ DRIP / DT - + IF(PRESENT(IRRIGATION_CHANNEL)) THEN + IF (IRRIGATION_CHANNEL.NE.0.)PCPDRP =PCPDRP+ 0.001*IRRIGATION_CHANNEL !conversion of units + END IF ! ---------------------------------------------------------------------- ! STORE ICE CONTENT AT EACH SOIL LAYER BEFORE CALLING SRT and SSTEP ! @@ -2685,28 +2775,40 @@ SUBROUTINE SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & ! INC&UDED IN SSTEP SUBR. FROZEN GROUND CORRECTION FACTOR, FRZFACT ! ADDED. ALL WATER BALANCE CALCULATIONS USING UNFROZEN WATER ! ---------------------------------------------------------------------- + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... Add previous ponded water to new precip drip... + PCPDRP = PCPDRP + SFHEAD1RT/1000./DT ! convert SFHEAD1RT to (m/s) +#endif + + IF ( ( (PCPDRP * DT) > (0.0001*1000.0* (- ZSOIL (1))* SMCMAX) ) & .OR. (FAC2 > FLIMIT) ) THEN CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & - RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT) CALL SSTEP (SH2OFG,SH2O,DUMMY,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & - CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) DO K = 1,NSOIL SH2OA (K) = (SH2O (K) + SH2OFG (K)) * 0.5 END DO CALL SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP,ZSOIL, & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & - RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) - CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & - CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT) + SH2OIN=SH2O + CALL SSTEP (SH2O,SH2OIN,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) ELSE CALL SRT (RHSTT,EDIR,ET,SH2O,SH2O,NSOIL,PCPDRP,ZSOIL, & DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & - RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI) - CALL SSTEP (SH2O,SH2O,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & - CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI) + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZFACT,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT) + SH2OIN=SH2O + CALL SSTEP (SH2O,SH2OIN,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,SMC,SICE,AI,BI,CI,INFXS1RT) ! RUNOF = RUNOFF END IF @@ -2716,7 +2818,9 @@ END SUBROUTINE SMFLX ! ---------------------------------------------------------------------- - SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) + SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR, & + XLAI,SHDFAC,FVB,GAMA,FBUR, & + FGSN,ZTOPV,ZBOTV,UA_PHYS) ! ---------------------------------------------------------------------- ! SUBROUTINE SNFRAC @@ -2730,8 +2834,19 @@ SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) IMPLICIT NONE REAL, INTENT(IN) :: SNEQV,SNUP,SALP,SNOWH - REAL, INTENT(INOUT) :: SNCOVR + REAL, INTENT(OUT) :: SNCOVR REAL :: RSNOW, Z0N + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(IN) :: ZTOPV ! UA: height of canopy top + REAL, INTENT(IN) :: ZBOTV ! UA: height of canopy bottom + REAL, INTENT(IN) :: SHDFAC ! UA: vegetation fraction + REAL, INTENT(INOUT) :: XLAI ! UA: LAI modified by snow + REAL, INTENT(OUT) :: FVB ! UA: frac. veg. w/snow beneath + REAL, INTENT(OUT) :: GAMA ! UA: = EXP(-1.* XLAI) + REAL, INTENT(OUT) :: FBUR ! UA: fraction of canopy buried + REAL, INTENT(OUT) :: FGSN ! UA: ground snow cover fraction + + REAL :: SNUPGRD = 0.02 ! UA: SWE limit for ground cover ! ---------------------------------------------------------------------- ! SNUP IS VEG-CLASS DEPENDENT SNOWDEPTH THRESHHOLD (SET IN ROUTINE @@ -2752,6 +2867,58 @@ SUBROUTINE SNFRAC (SNEQV,SNUP,SALP,SNOWH,SNCOVR) ! FORMULATION OF MARSHALL ET AL. 1994 ! SNCOVR=SNEQV/(SNEQV + 2*Z0N) + IF(UA_PHYS) THEN + +!--------------------------------------------------------------------- +! FGSN: FRACTION OF SOIL COVERED WITH SNOW +!--------------------------------------------------------------------- + IF (SNEQV < SNUPGRD) THEN + FGSN = SNEQV / SNUPGRD + ELSE + FGSN = 1.0 + END IF +!------------------------------------------------------------------ +! FBUR: VERTICAL FRACTION OF VEGETATION COVERED BY SNOW +! GRASS, CROP, AND SHRUB: MULTIPLY 0.4 BY ZTOPV AND ZBOTV BECAUSE +! THEY WILL BE PRESSED DOWN BY THE SNOW. +! FOREST: DON'T NEED TO CHANGE ZTOPV AND ZBOTV. + + IF(ZBOTV > 0. .AND. SNOWH > ZBOTV) THEN + IF(ZBOTV <= 0.5) THEN + FBUR = (SNOWH - 0.4*ZBOTV) / (0.4*(ZTOPV-ZBOTV)) ! short veg. + ELSE + FBUR = (SNOWH - ZBOTV) / (ZTOPV-ZBOTV) ! tall veg. + ENDIF + ELSE + FBUR = 0. + ENDIF + + FBUR = MIN(MAX(FBUR,0.0),1.0) + +! XLAI IS ADJUSTED FOR VERTICAL BURYING BY SNOW + XLAI = XLAI * (1.0 - FBUR) +! ---------------------------------------------------------------------- +! SNOW-COVERED SOIL: (1-SHDFAC)*FGSN +! VEGETATION WITH SNOW ABOVE DUE TO BURIAL FVEG_SN_AB = SHDFAC*FBUR +! SNOW ON THE GROUND THAT CAN BE "SEEN" BY SATELLITE +! (IF XLAI GOES TO ZERO): GAMA*FVB +! Where GAMA = exp(-XLAI) +! ---------------------------------------------------------------------- + +! VEGETATION WITH SNOW BELOW + FVB = SHDFAC * FGSN * (1.0 - FBUR) + +! GAMA IS USED TO DIVIDE FVB INTO TWO PARTS: +! GAMA=1 FOR XLAI=0 AND GAMA=0 FOR XLAI=6 + GAMA = EXP(-1.* XLAI) + ELSE + ! Define intent(out) terms for .NOT. UA_PHYS case + FVB = 0.0 + GAMA = 0.0 + FBUR = 0.0 + FGSN = 0.0 + END IF ! UA_PHYS + ! ---------------------------------------------------------------------- END SUBROUTINE SNFRAC ! ---------------------------------------------------------------------- @@ -2852,13 +3019,14 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & SNOWH,SH2O,SLOPE,KDT,FRZFACT,PSISAT, & ZSOIL,DWSAT,DKSAT,TBOT,ZBOT,SHDFAC,RUNOFF1, & RUNOFF2,RUNOFF3,EDIR,EC,ET,ETT,NROOT,SNOMLT, & - ICE,RTDIS,QUARTZ,FXEXP,CSOIL, & + RTDIS,QUARTZ,FXEXP,CSOIL, & BETA,DRIP,DEW,FLX1,FLX2,FLX3,ESNOW,ETNS,EMISSI,& RIBB,SOLDN, & ISURBAN, & - - VEGTYP) - + VEGTYP, & + ETPN,FLX4,UA_PHYS, & + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,QFX_PHY,fasdas,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE SNOPAC ! ---------------------------------------------------------------------- @@ -2868,7 +3036,8 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: ICE, NROOT, NSOIL,VEGTYP + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NROOT, NSOIL,VEGTYP,SOILTYP INTEGER, INTENT(IN) :: ISURBAN INTEGER :: K ! @@ -2876,6 +3045,10 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! INTEGER :: IT16 LOGICAL, INTENT(IN) :: SNOWNG + +!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: SFHEAD1RT,INFXS1RT,ETPND1 + REAL, INTENT(IN) :: BEXP,CFACTR, CMCMAX,CSOIL,DF1,DKSAT, & DT,DWSAT, EPSCA,FDOWN,F1,FXEXP, & FRZFACT,KDT,PC, PRCP,PSISAT,Q2,QUARTZ, & @@ -2884,11 +3057,11 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & TBOT,TH2,ZBOT,EMISSI,SOLDN REAL, INTENT(INOUT) :: CMC, BETA, ESD,FLX2,PRCPF,SNOWH,SNCOVR, & SNDENS, T1, RIBB, ETP - REAL, INTENT(INOUT) :: DEW,DRIP,EC,EDIR, ETNS, ESNOW,ETT, & + REAL, INTENT(OUT) :: DEW,DRIP,EC,EDIR, ETNS, ESNOW,ETT, & FLX1,FLX3, RUNOFF1,RUNOFF2,RUNOFF3, & SSOIL,SNOMLT REAL, DIMENSION(1:NSOIL),INTENT(IN) :: RTDIS,ZSOIL - REAL, DIMENSION(1:NSOIL),INTENT(INOUT) :: ET + REAL, DIMENSION(1:NSOIL),INTENT(OUT) :: ET REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC,SH2O,STC REAL, DIMENSION(1:NSOIL) :: ET1 REAL :: DENOM,DSOIL,DTOT,EC1,EDIR1,ESDFLX,ETA, & @@ -2905,15 +3078,23 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & LSUBS = 2.83E+6, TFREEZ = 273.15, & SNOEXP = 2.0 + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(INOUT) :: FLX4 ! UA: energy removed by canopy + REAL, INTENT(IN) :: ETPN ! UA: adjusted pot. evap. [mm/s] + REAL :: ETP1N ! UA: adjusted pot. evap. [m/s] +! +! FASDAS +! + REAL :: QFX_PHY + INTEGER :: fasdas + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE: ! ---------------------------------------------------------------------- -! IF SEA-ICE (ICE=1) OR GLACIAL-ICE (ICE=-1), SNOWCOVER FRACTION = 1.0, -! AND SUBLIMATION IS AT THE POTENTIAL RATE. -! FOR NON-GLACIAL LAND (ICE=0), IF SNOWCOVER FRACTION < 1.0, TOTAL -! EVAPORATION < POTENTIAL DUE TO NON-POTENTIAL CONTRIBUTION FROM -! NON-SNOW COVERED FRACTION. ! ---------------------------------------------------------------------- ! INITIALIZE EVAP TERMS. ! ---------------------------------------------------------------------- @@ -2939,6 +3120,11 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & END DO ETT = 0. ETT1 = 0. + +!DJG NDHMS/WRF-Hydro edit... + ETPND1 = 0. + + ETNS = 0. ETNS1 = 0. ESNOW = 0. @@ -2957,58 +3143,68 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN ETP=(MIN(ETP*(1.0-RIBB),0.)*SNCOVR/0.980 + ETP*(0.980-SNCOVR))/0.980 ENDIF - IF(ETP == 0.) BETA = 0.0 - ETP1 = ETP * 0.001 + IF(ETP == 0.) BETA = 0.0 + ETP1 = ETP * 0.001 + IF(UA_PHYS) ETP1N = ETPN * 0.001 DEW = -ETP1 ESNOW2 = ETP1*DT ETANRG = ETP*((1.-SNCOVR)*LSUBC + SNCOVR*LSUBS) ELSE ETP1 = ETP * 0.001 - IF ( ICE /= 0 ) THEN - ! SEA-ICE AND GLACIAL-ICE CASE - ESNOW = ETP - ESNOW1 = ESNOW*0.001 - ESNOW2 = ESNOW1*DT - ETANRG = ESNOW*LSUBS - ELSE IF ( ICE == 0) THEN - ! NON-GLACIAL LAND CASE - IF (SNCOVR < 1.) THEN - CALL EVAPO (ETNS1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & - SH2O, & - SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & - SMCREF,SHDFAC,CMCMAX, & - SMCDRY,CFACTR, & - EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS, & - FXEXP) + IF(UA_PHYS) ETP1N = ETPN * 0.001 + ! LAND CASE + IF (SNCOVR < 1.) THEN + CALL EVAPO (ETNS1,SMC,NSOIL,CMC,ETP1,DT,ZSOIL, & + SH2O, & + SMCMAX,BEXP,PC,SMCWLT,DKSAT,DWSAT, & + SMCREF,SHDFAC,CMCMAX, & + SMCDRY,CFACTR, & + EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS, & + FXEXP, SFHEAD1RT,ETPND1) ! ---------------------------------------------------------------------------- - EDIR1 = EDIR1* (1. - SNCOVR) - EC1 = EC1* (1. - SNCOVR) - DO K = 1,NSOIL - ET1 (K) = ET1 (K)* (1. - SNCOVR) - END DO - ETT1 = ETT1*(1.-SNCOVR) -! ETNS1 = EDIR1+ EC1+ ETT1 - ETNS1 = ETNS1*(1.-SNCOVR) + EDIR1 = EDIR1* (1. - SNCOVR) + EC1 = EC1* (1. - SNCOVR) + DO K = 1,NSOIL + ET1 (K) = ET1 (K)* (1. - SNCOVR) + END DO + ETT1 = ETT1*(1.-SNCOVR) +! ETNS1 = EDIR1+ EC1+ ETT1 + ETNS1 = ETNS1*(1.-SNCOVR) ! ---------------------------------------------------------------------------- - EDIR = EDIR1*1000. - EC = EC1*1000. - DO K = 1,NSOIL - ET (K) = ET1 (K)*1000. - END DO - ETT = ETT1*1000. - ETNS = ETNS1*1000. + EDIR = EDIR1*1000. + EC = EC1*1000. + DO K = 1,NSOIL + ET (K) = ET1 (K)*1000. + END DO +! +! FASDAS +! + if( fasdas == 1 ) then + QFX_PHY = EDIR + EC + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET(K) + END DO + endif +! +! END FASDAS +! + ETT = ETT1*1000. + ETNS = ETNS1*1000. + + +!DJG NDHMS/WRF-Hydro edit... + ETPND1 = ETPND1*1000. + + ! ---------------------------------------------------------------------- -! end IF (SNCOVR .lt. 1.) - END IF -! end IF (ICE .ne. 1) - END IF + ENDIF ESNOW = ETP*SNCOVR + IF(UA_PHYS) ESNOW = ETPN*SNCOVR ! USE ADJUSTED ETP ESNOW1 = ESNOW*0.001 ESNOW2 = ESNOW1*DT ETANRG = ESNOW*LSUBS + ETNS*LSUBC -! end IF (ETP .le. 0.0) - END IF + ENDIF ! ---------------------------------------------------------------------- ! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY @@ -3064,6 +3260,7 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & EX = 0.0 SNOMLT = 0.0 + IF(UA_PHYS) FLX4 = 0.0 ! ---------------------------------------------------------------------- ! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT ! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE @@ -3080,7 +3277,9 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! ABOVE FREEZING BLOCK ! ---------------------------------------------------------------------- ELSE - T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP) +! From V3.9 original code (commented) replaced to allow complete melting of small snow amounts +! T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP) + T1 = TFREEZ * max(0.01,SNCOVR ** SNOEXP) + T12 * (1.0- max(0.01,SNCOVR ** SNOEXP)) BETA = 1.0 ! ---------------------------------------------------------------------- @@ -3088,19 +3287,13 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! BETA<1 ! SNOWPACK HAS SUBLIMATED AWAY, SET DEPTH TO ZERO. ! ---------------------------------------------------------------------- - IF ( ICE /= 0 ) then - ! kmh 12/15/2005 modify SSOIL - ! kmh 09/03/2006 modify DTOT - IF ( DTOT .GT. 2.0*DSOIL ) THEN - DTOT = 2.0*DSOIL - ENDIF - ENDIF SSOIL = DF1 * (T1- STC (1)) / DTOT IF (ESD-ESNOW2 <= ESDMIN) THEN ESD = 0.0 EX = 0.0 SNOMLT = 0.0 FLX3 = 0.0 + IF(UA_PHYS) FLX4 = 0.0 ! ---------------------------------------------------------------------- ! SUBLIMATION LESS THAN DEPTH OF SNOWPACK ! SNOWPACK (ESD) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) @@ -3116,6 +3309,18 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! SSOIL - SEH - ETANRG FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG IF (FLX3 <= 0.0) FLX3 = 0.0 + + IF(UA_PHYS .AND. FLX4 > 0. .AND. FLX3 > 0.) THEN + IF(FLX3 >= FLX4) THEN + FLX3 = FLX3 - FLX4 + ELSE + FLX4 = FLX3 + FLX3 = 0. + ENDIF + ELSE + FLX4 = 0.0 + ENDIF + ! ---------------------------------------------------------------------- ! SNOWMELT REDUCTION DEPENDING ON SNOW COVER ! ---------------------------------------------------------------------- @@ -3150,30 +3355,25 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! IF NON-GLACIAL LAND, ADD SNOWMELT RATE (EX) TO PRECIP RATE TO BE USED ! IN SUBROUTINE SMFLX (SOIL MOISTURE EVOLUTION) VIA INFILTRATION. ! -! FOR SEA-ICE AND GLACIAL-ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE ! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO ! SUBROUTINE SNOPAC) ! ---------------------------------------------------------------------- - IF (ICE == 0) PRCP1 = PRCP1+ EX + PRCP1 = PRCP1+ EX ! ---------------------------------------------------------------------- ! SET THE EFFECTIVE POTNL EVAPOTRANSP (ETP1) TO ZERO SINCE THIS IS SNOW ! CASE, SO SURFACE EVAP NOT CALCULATED FROM EDIR, EC, OR ETT IN SMFLX ! (BELOW). -! IF SEAICE (ICE==1) SKIP CALL TO SMFLX. ! SMFLX RETURNS UPDATED SOIL MOISTURE VALUES FOR NON-GLACIAL LAND. -! IF SEA-ICE (ICE==1) OR GLACIAL-ICE (ICE==-1), SKIP CALL TO SMFLX, -! SINCE NO SOIL MEDIUM FOR SEA-ICE OR GLACIAL-ICE. ! ---------------------------------------------------------------------- END IF - IF (ICE == 0) THEN - CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & - SH2O,SLOPE,KDT,FRZFACT, & - SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & - SHDFAC,CMCMAX, & - RUNOFF1,RUNOFF2,RUNOFF3, & - EDIR1,EC1,ET1, & - DRIP) + CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & + SH2O,SLOPE,KDT,FRZFACT, & + SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + SHDFAC,CMCMAX, & + RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR1,EC1,ET1, & + DRIP, SFHEAD1RT,INFXS1RT) ! ---------------------------------------------------------------------- ! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO ! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX @@ -3182,7 +3382,6 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! SNOW TOP SURFACE. T11 IS A DUMMY ARGUEMENT SO WE WILL NOT USE THE ! SKIN TEMP VALUE AS REVISED BY SHFLX. ! ---------------------------------------------------------------------- - END IF ZZ1 = 1.0 YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 @@ -3194,54 +3393,32 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! UPDATED INSTEAD NEAR THE BEGINNING OF THE CALL TO SNOPAC. ! ---------------------------------------------------------------------- T11 = T1 - CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, & - TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1,ICE, & - QUARTZ,CSOIL,VEGTYP,ISURBAN) + CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS ! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. ! ---------------------------------------------------------------------- - IF (ICE == 0) THEN - ! NON-GLACIAL LAND - IF (ESD > 0.) THEN - CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) - ELSE - ESD = 0. - SNOWH = 0. - SNDENS = 0. - SNCOND = 1. - SNCOVR = 0. - END IF - ELSEIF (ICE == 1) THEN - ! SEA-ICE - IF (ESD .GE. 0.01) THEN - CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) - ELSE - ESD = 0.01 - SNOWH = 0.05 - !KWM???? SNDENS = - !KWM???? SNCOND = - SNCOVR = 1.0 - ENDIF - ELSEIF (ICE == -1) THEN - ! GLACIAL-ICE - IF (ESD .GE. 0.10) THEN - CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY) - ELSE - ESD = 0.10 - SNOWH = 0.50 - !KWM???? SNDENS = - !KWM???? SNCOND = - SNCOVR = 1.0 - ENDIF - ENDIF + ! LAND + IF (ESD > 0.) THEN + CALL SNOWPACK (ESD,DT,SNOWH,SNDENS,T1,YY,SNOMLT,UA_PHYS) + ELSE + ESD = 0. + SNOWH = 0. + SNDENS = 0. + SNCOND = 1. + SNCOVR = 0. + END IF + ! ---------------------------------------------------------------------- END SUBROUTINE SNOPAC ! ---------------------------------------------------------------------- - SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) + SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL,SNOMLT,UA_PHYS) ! ---------------------------------------------------------------------- ! SUBROUTINE SNOWPACK @@ -3269,11 +3446,15 @@ SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) TAVGC,TSNOWC,TSOILC,ESDC,ESDCX REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, & KN = 4000.0 + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(IN) :: SNOMLT ! UA: snow melt [m] + REAL :: SNOMLTC ! UA: snow melt [cm] ! ---------------------------------------------------------------------- ! CONVERSION INTO SIMULATION UNITS ! ---------------------------------------------------------------------- SNOWHC = SNOWH *100. ESDC = ESD *100. + IF(UA_PHYS) SNOMLTC = SNOMLT *100. DTHR = DTSEC /3600. TSNOWC = TSNOW -273.15 TSOILC = TSOIL -273.15 @@ -3299,7 +3480,7 @@ SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) ! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) ! ---------------------------------------------------------------------- -! THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION +! THE FUNCTION OF THE FORM (e**x-1)/x EMBEDDED IN ABOVE EXPRESSION ! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" ! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT ! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS @@ -3355,6 +3536,9 @@ SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) SNDENS = DSX IF (TSNOWC >= 0.) THEN DW = 0.13* DTHR /24. + IF ( UA_PHYS .AND. TSOILC >= 0.) THEN + DW = MIN (DW, 0.13*SNOMLTC/(ESDCX+0.13*SNOMLTC)) + ENDIF SNDENS = SNDENS * (1. - DW) + DW IF (SNDENS >= 0.40) SNDENS = 0.40 ! ---------------------------------------------------------------------- @@ -3369,7 +3553,7 @@ SUBROUTINE SNOWPACK (ESD,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) END SUBROUTINE SNOWPACK ! ---------------------------------------------------------------------- - SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH) + SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH,FBUR,FGSN,SHDMAX,UA_PHYS) ! ---------------------------------------------------------------------- ! SUBROUTINE SNOWZ0 @@ -3381,22 +3565,38 @@ SUBROUTINE SNOWZ0 (SNCOVR,Z0, Z0BRD, SNOWH) ! ---------------------------------------------------------------------- IMPLICIT NONE REAL, INTENT(IN) :: SNCOVR, Z0BRD - REAL, INTENT(INOUT) :: Z0 + REAL, INTENT(OUT) :: Z0 REAL, PARAMETER :: Z0S=0.001 REAL, INTENT(IN) :: SNOWH REAL :: BURIAL REAL :: Z0EFF + LOGICAL, INTENT(IN) :: UA_PHYS ! UA: flag for UA option + REAL, INTENT(IN) :: FBUR ! UA: fraction of canopy buried + REAL, INTENT(IN) :: FGSN ! UA: ground snow cover fraction + REAL, INTENT(IN) :: SHDMAX ! UA: maximum vegetation fraction + REAL, PARAMETER :: Z0G=0.01 ! UA: soil roughness + REAL :: FV,A1,A2 -!m Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S - BURIAL = 7.0*Z0BRD - SNOWH - IF(BURIAL.LE.0.0007) THEN - Z0EFF = Z0S - ELSE - Z0EFF = BURIAL/7.0 - ENDIF + IF(UA_PHYS) THEN + + FV = SHDMAX * (1.-FBUR) + A1 = (1.-FV)**2*((1.-FGSN**2)*LOG(Z0G) + (FGSN**2)*LOG(Z0S)) + A2 = (1.-(1.-FV)**2)*LOG(Z0BRD) + Z0 = EXP(A1+A2) + + ELSE + +!m Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0S + BURIAL = 7.0*Z0BRD - SNOWH + IF(BURIAL.LE.0.0007) THEN + Z0EFF = Z0S + ELSE + Z0EFF = BURIAL/7.0 + ENDIF - Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF + Z0 = (1.- SNCOVR)* Z0BRD + SNCOVR * Z0EFF + ENDIF ! ---------------------------------------------------------------------- END SUBROUTINE SNOWZ0 ! ---------------------------------------------------------------------- @@ -3407,7 +3607,7 @@ SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) ! ---------------------------------------------------------------------- ! SUBROUTINE SNOW_NEW ! ---------------------------------------------------------------------- -! CALCULATE SNOW DEPTH AND DENSITITY TO ACCOUNT FOR THE NEW SNOWFALL. +! CALCULATE SNOW DEPTH AND DENSITY TO ACCOUNT FOR THE NEW SNOWFALL. ! NEW VALUES OF SNOW DEPTH & DENSITY RETURNED. ! TEMP AIR TEMPERATURE (K) @@ -3456,7 +3656,8 @@ END SUBROUTINE SNOW_NEW SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & ZSOIL,DWSAT,DKSAT,SMCMAX,BEXP,RUNOFF1, & - RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI) + RUNOFF2,DT,SMCWLT,SLOPE,KDT,FRZX,SICE,AI,BI,CI, & + SFHEAD1RT,INFXS1RT ) ! ---------------------------------------------------------------------- ! SUBROUTINE SRT @@ -3468,13 +3669,20 @@ SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & IMPLICIT NONE INTEGER, INTENT(IN) :: NSOIL INTEGER :: IALP1, IOHINF, J, JJ, K, KS + +!DJG NDHMS/WRF-Hydro edit... Variables used in OV routing infiltration calcs + REAL, INTENT(INOUT) :: SFHEAD1RT, INFXS1RT + REAL :: SFCWATR,chcksm + + + REAL, INTENT(IN) :: BEXP, DKSAT, DT, DWSAT, EDIR, FRZX, & KDT, PCPDRP, SLOPE, SMCMAX, SMCWLT - REAL, INTENT(INOUT) :: RUNOFF1, RUNOFF2 + REAL, INTENT(OUT) :: RUNOFF1, RUNOFF2 REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ET, SH2O, SH2OA, SICE, & ZSOIL - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI, CI REAL, DIMENSION(1:NSOIL) :: DMAX REAL :: ACRT, DD, DDT, DDZ, DDZ2, DENOM, & DENOM2,DICE, DSMDZ, DSMDZ2, DT1, & @@ -3511,15 +3719,34 @@ SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & ! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF ! ---------------------------------------------------------------------- END DO + +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Use previously merged Precip and Sfchead for infil. cap. calc. + SFCWATR = PCPDRP + PDDUM = SFCWATR +!DJG original PDDUM = PCPDRP + RUNOFF1 = 0.0 + INFXS1RT = 0.0 +#else PDDUM = PCPDRP RUNOFF1 = 0.0 +#endif + + ! ---------------------------------------------------------------------- ! MODIFIED BY Q. DUAN, 5/16/94 ! ---------------------------------------------------------------------- ! IF (IOHINF == 1) THEN - IF (PCPDRP /= 0.0) THEN +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP /= 0.0) THEN + IF (SFCWATR /= 0.0) THEN +#else + IF (PCPDRP /= 0.0) THEN +#endif DT1 = DT /86400. SMCAV = SMCMAX - SMCWLT @@ -3551,9 +3778,17 @@ SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & END DO VAL = (1. - EXP ( - KDT * DT1)) DDT = DD * VAL +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG PX = PCPDRP * DT + PX = SFCWATR * DT +#else PX = PCPDRP * DT +#endif IF (PX < 0.0) PX = 0.0 + + ! ---------------------------------------------------------------------- ! FROZEN GROUND VERSION: ! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS @@ -3588,10 +3823,20 @@ SUBROUTINE SRT (RHSTT,EDIR,ET,SH2O,SH2OA,NSOIL,PCPDRP, & INFMAX = MAX (INFMAX,WCND) INFMAX = MIN (INFMAX,PX/DT) +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG IF (PCPDRP > INFMAX) THEN + IF (SFCWATR > INFMAX) THEN +!DJG RUNOFF1 = PCPDRP - INFMAX + RUNOFF1 = SFCWATR - INFMAX +#else IF (PCPDRP > INFMAX) THEN RUNOFF1 = PCPDRP - INFMAX - PDDUM = INFMAX +#endif + INFXS1RT = RUNOFF1*DT*1000. + PDDUM = INFMAX END IF + ! ---------------------------------------------------------------------- ! TO AVOID SPURIOUS DRAINAGE BEHAVIOR, 'UPSTREAM DIFFERENCING' IN LINE ! BELOW REPLACED WITH NEW APPROACH IN 2ND LINE: @@ -3708,7 +3953,7 @@ END SUBROUTINE SRT SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL,SMC,SICE, & - AI,BI,CI) + AI,BI,CI, INFXS1RT) ! ---------------------------------------------------------------------- ! SUBROUTINE SSTEP @@ -3720,11 +3965,15 @@ SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & INTEGER, INTENT(IN) :: NSOIL INTEGER :: I, K, KK11 +!!DJG NDHMS/WRF-Hydro edit... + REAL, INTENT(INOUT) :: INFXS1RT + REAL :: AVAIL + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX - REAL, INTENT(INOUT) :: RUNOFF3 + REAL, INTENT(OUT) :: RUNOFF3 REAL, INTENT(INOUT) :: CMC REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2OIN, SICE, ZSOIL - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2OOUT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SH2OOUT REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT, SMC REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI REAL, DIMENSION(1:NSOIL) :: RHSTTin @@ -3781,6 +4030,43 @@ SUBROUTINE SSTEP (SH2OOUT,SH2OIN,CMC,RHSTT,RHSCT,DT, & SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) END DO +#ifdef WRF_HYDRO +!DJG NDHMS/WRF-Hydro edit... +!DJG Modifications to redstribute WPLUS/RUNOFF3 (soil moisture closure error) to soil profile +!DJG beginning at bottom layer (NSOIL) + IF (WPLUS > 0.) THEN + DO K=NSOIL,2,-1 + + IF (K .eq. 2) THEN !Assign soil depths + DDZ = -ZSOIL(1) + ELSE + DDZ = ZSOIL(K-2)-ZSOIL(K-1) + END IF + + AVAIL = (SMCMAX - SMC(K-1)) * DDZ !Det. Avail. Stor. + +! print *, "ZZZZZ", K,DDZ,AVAIL,WPLUS,SMC(K),SMC(K-1),SMCMAX + + IF (WPLUS <= AVAIL) THEN + SMC(K-1) = SMC(K-1) + WPLUS/DDZ + WPLUS = 0. + ELSE + SMC(K-1) = SMCMAX + WPLUS = WPLUS - AVAIL + IF (K-1 .eq. 1) THEN + INFXS1RT = INFXS1RT + WPLUS*1000 + WPLUS = 0. + END IF + END IF + +! SMC (K) = MAX ( MIN (STOT,SMCMAX),0.02 ) + SH2OOUT (K) = MAX ( (SMC (K) - SICE (K)),0.0) + + END DO + END IF +!DJG NDHMS/WRF-Hydro edit...End of modification +#endif + ! ---------------------------------------------------------------------- ! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO @@ -3807,7 +4093,7 @@ SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) INTEGER, INTENT(IN) :: NSOIL INTEGER :: K REAL, INTENT(IN) :: TB, TU, ZBOT - REAL, INTENT(INOUT) :: TBND1 + REAL, INTENT(OUT) :: TBND1 REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL REAL :: ZB, ZUP REAL, PARAMETER :: T0 = 273.15 @@ -3839,7 +4125,7 @@ END SUBROUTINE TBND ! ---------------------------------------------------------------------- - SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) + SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O, BEXP, PSISAT, SOILTYP, OPT_THCND) ! ---------------------------------------------------------------------- ! SUBROUTINE TDFCND @@ -3851,11 +4137,12 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) ! June 2001 CHANGES: FROZEN SOIL CONDITION. ! ---------------------------------------------------------------------- IMPLICIT NONE - REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O - REAL, INTENT(INOUT) :: DF + INTEGER, INTENT(IN) :: SOILTYP, OPT_THCND + REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O, BEXP, PSISAT + REAL, INTENT(OUT) :: DF REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, & THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, & - XUNFROZ + XUNFROZ,AKEI,AKEL,PSIF,PF ! ---------------------------------------------------------------------- ! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): @@ -3886,6 +4173,9 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) ! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, ! VOL. 55, PP. 1209-1224. ! ---------------------------------------------------------------------- + +IF ( OPT_THCND == 1 .OR. ( OPT_THCND == 2 .AND. (SOILTYP /= 4 .AND. SOILTYP /= 3)) )THEN + ! NEEDS PARAMETERS ! POROSITY(SOIL TYPE): ! POROS = SMCMAX @@ -3919,11 +4209,9 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) ! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) ! FROZEN - IF ( (SH2O + 0.0005) < SMC ) THEN - AKE = SATRATIO + AKEI = SATRATIO ! UNFROZEN ! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) - ELSE ! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT ! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) @@ -3931,18 +4219,34 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) IF ( SATRATIO > 0.1 ) THEN - AKE = LOG10 (SATRATIO) + 1.0 + AKEL = LOG10 (SATRATIO) + 1.0 ! USE K = KDRY ELSE - AKE = 0.0 + AKEL = 0.0 END IF + AKE = ((SMC-SH2O)*AKEI + SH2O*AKEL)/SMC ! THERMAL CONDUCTIVITY - END IF DF = AKE * (THKSAT - THKDRY) + THKDRY + + ELSE + +! use the Mccumber and Pielke approach for silt loam (4), sandy loam (3) + + PSIF = PSISAT*100.*(SMCMAX/(SMC))**BEXP +!--- PSIF should be in [CM] to compute PF + PF=log10(abs(PSIF)) +!--- HK is for McCumber thermal conductivity + IF(PF.LE.5.1) THEN + DF=420.*EXP(-(PF+2.7)) + ELSE + DF=.1744 + END IF + + ENDIF ! for OPT_THCND OPTIONS ! ---------------------------------------------------------------------- END SUBROUTINE TDFCND ! ---------------------------------------------------------------------- diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F new file mode 100644 index 0000000000..1d39e80beb --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_noahlsm_glacial_only.F @@ -0,0 +1,1284 @@ +!================================================================================================================= +MODULE module_sf_noahlsm_glacial_only + +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_constants +use mpas_atmphys_utilities, only: physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#else +use module_model_constants +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#endif + + USE module_sf_noahlsm, ONLY : RD, SIGMA, CPH2O, CPICE, LSUBF, EMISSI_S, ROSR12 + USE module_sf_noahlsm, ONLY : LVCOEF_DATA + + PRIVATE :: ALCALC + PRIVATE :: CSNOW + PRIVATE :: HRTICE + PRIVATE :: HSTEP + PRIVATE :: PENMAN + PRIVATE :: SHFLX + PRIVATE :: SNOPAC + PRIVATE :: SNOWPACK + PRIVATE :: SNOWZ0 + PRIVATE :: SNOW_NEW + + integer, private :: iloc, jloc +!$omp threadprivate(iloc, jloc) + +CONTAINS + + SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & !C + & LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2, & !F + & TH2,Q2SAT,DQSDT2, & !I + & ALB, SNOALB,TBOT, Z0BRD, Z0, EMISSI, EMBRD, & !S + & T1,STC,SNOWH,SNEQV,ALBEDO,CH, & !H +! ---------------------------------------------------------------------- +! OUTPUTS, DIAGNOSTICS, PARAMETERS BELOW GENERALLY NOT NECESSARY WHEN +! COUPLED WITH E.G. A NWP MODEL (SUCH AS THE NOAA/NWS/NCEP MESOSCALE ETA +! MODEL). OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ---------------------------------------------------------------------- + & ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + & ESNOW,DEW, & !O + & ETP,SSOIL, & !O + & FLX1,FLX2,FLX3, & !O + & SNOMLT,SNCOVR, & !O + & RUNOFF1, & !O + & Q1, & !D + & SNOTIME1, & + & RIBB) +! ---------------------------------------------------------------------- +! SUB-DRIVER FOR "Noah LSM" FAMILY OF PHYSICS SUBROUTINES FOR A +! SOIL/VEG/SNOWPACK LAND-SURFACE MODEL TO UPDATE ICE TEMPERATURE, SKIN +! TEMPERATURE, SNOWPACK WATER CONTENT, SNOWDEPTH, AND ALL TERMS OF THE +! SURFACE ENERGY BALANCE (EXCLUDING INPUT ATMOSPHERIC FORCINGS OF +! DOWNWARD RADIATION AND PRECIP) +! ---------------------------------------------------------------------- +! SFLX ARGUMENT LIST KEY: +! ---------------------------------------------------------------------- +! C CONFIGURATION INFORMATION +! F FORCING DATA +! I OTHER (INPUT) FORCING DATA +! S SURFACE CHARACTERISTICS +! H HISTORY (STATE) VARIABLES +! O OUTPUT VARIABLES +! D DIAGNOSTIC OUTPUT +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- +! DT TIMESTEP (SEC) (DT SHOULD NOT EXCEED 3600 SECS, RECOMMEND +! 1800 SECS OR LESS) +! ZLVL HEIGHT (M) ABOVE GROUND OF ATMOSPHERIC FORCING VARIABLES +! NSOIL NUMBER OF SOIL LAYERS (AT LEAST 2, AND NOT GREATER THAN +! PARAMETER NSOLD SET BELOW) +! SLDPTH THE THICKNESS OF EACH SOIL LAYER (M) +! ---------------------------------------------------------------------- +! 3. FORCING DATA (F): +! ---------------------------------------------------------------------- +! LWDN LW DOWNWARD RADIATION (W M-2; POSITIVE, NOT NET LONGWAVE) +! SOLNET NET DOWNWARD SOLAR RADIATION ((W M-2; POSITIVE) +! SFCPRS PRESSURE AT HEIGHT ZLVL ABOVE GROUND (PASCALS) +! PRCP PRECIP RATE (KG M-2 S-1) (NOTE, THIS IS A RATE) +! SFCTMP AIR TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! TH2 AIR POTENTIAL TEMPERATURE (K) AT HEIGHT ZLVL ABOVE GROUND +! Q2 MIXING RATIO AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! FFROZP FRACTION OF FROZEN PRECIPITATION +! ---------------------------------------------------------------------- +! 4. OTHER FORCING (INPUT) DATA (I): +! ---------------------------------------------------------------------- +! Q2SAT SAT SPECIFIC HUMIDITY AT HEIGHT ZLVL ABOVE GROUND (KG KG-1) +! DQSDT2 SLOPE OF SAT SPECIFIC HUMIDITY CURVE AT T=SFCTMP +! (KG KG-1 K-1) +! ---------------------------------------------------------------------- +! 5. CANOPY/SOIL CHARACTERISTICS (S): +! ---------------------------------------------------------------------- +! ALB BACKROUND SNOW-FREE SURFACE ALBEDO (FRACTION), FOR JULIAN +! DAY OF YEAR (USUALLY FROM TEMPORAL INTERPOLATION OF +! MONTHLY MEAN VALUES' CALLING PROG MAY OR MAY NOT +! INCLUDE DIURNAL SUN ANGLE EFFECT) +! SNOALB UPPER BOUND ON MAXIMUM ALBEDO OVER DEEP SNOW (E.G. FROM +! ROBINSON AND KUKLA, 1985, J. CLIM. & APPL. METEOR.) +! TBOT BOTTOM SOIL TEMPERATURE (LOCAL YEARLY-MEAN SFC AIR +! TEMPERATURE) +! Z0BRD Background fixed roughness length (M) +! Z0 Time varying roughness length (M) as function of snow depth +! EMBRD Background surface emissivity (between 0 and 1) +! EMISSI Surface emissivity (between 0 and 1) +! ---------------------------------------------------------------------- +! 6. HISTORY (STATE) VARIABLES (H): +! ---------------------------------------------------------------------- +! T1 GROUND/CANOPY/SNOWPACK) EFFECTIVE SKIN TEMPERATURE (K) +! STC(NSOIL) SOIL TEMP (K) +! SNOWH ACTUAL SNOW DEPTH (M) +! SNEQV LIQUID WATER-EQUIVALENT SNOW DEPTH (M) +! NOTE: SNOW DENSITY = SNEQV/SNOWH +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT (UNITLESS FRACTION) +! =SNOW-FREE ALBEDO (ALB) WHEN SNEQV=0, OR +! =FCT(MSNOALB,ALB,SHDFAC,SHDMIN) WHEN SNEQV>0 +! CH SURFACE EXCHANGE COEFFICIENT FOR HEAT AND MOISTURE +! (M S-1); NOTE: CH IS TECHNICALLY A CONDUCTANCE SINCE +! IT HAS BEEN MULTIPLIED BY WIND SPEED. +! ---------------------------------------------------------------------- +! 7. OUTPUT (O): +! ---------------------------------------------------------------------- +! OUTPUT VARIABLES NECESSARY FOR A COUPLED NUMERICAL WEATHER PREDICTION +! MODEL, E.G. NOAA/NWS/NCEP MESOSCALE ETA MODEL. FOR THIS APPLICATION, +! THE REMAINING OUTPUT/DIAGNOSTIC/PARAMETER BLOCKS BELOW ARE NOT +! NECESSARY. OTHER APPLICATIONS MAY REQUIRE DIFFERENT OUTPUT VARIABLES. +! ETA ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM +! SURFACE) +! ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1 +! SHEAT SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM +! SURFACE) +! FDOWN Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN +! ---------------------------------------------------------------------- +! ESNOW SUBLIMATION FROM (OR DEPOSITION TO IF <0) SNOWPACK +! (W m-2) +! DEW DEWFALL (OR FROSTFALL FOR T<273.15) (M) +! ---------------------------------------------------------------------- +! ETP POTENTIAL EVAPORATION (W m-2) +! SSOIL SOIL HEAT FLUX (W M-2: NEGATIVE IF DOWNWARD FROM SURFACE) +! ---------------------------------------------------------------------- +! FLX1 PRECIP-SNOW SFC (W M-2) +! FLX2 FREEZING RAIN LATENT HEAT FLUX (W M-2) +! FLX3 PHASE-CHANGE HEAT FLUX FROM SNOWMELT (W M-2) +! ---------------------------------------------------------------------- +! SNOMLT SNOW MELT (M) (WATER EQUIVALENT) +! SNCOVR FRACTIONAL SNOW COVER (UNITLESS FRACTION, 0-1) +! ---------------------------------------------------------------------- +! RUNOFF1 SURFACE RUNOFF (M S-1), NOT INFILTRATING THE SURFACE +! ---------------------------------------------------------------------- +! 8. DIAGNOSTIC OUTPUT (D): +! ---------------------------------------------------------------------- +! Q1 Effective mixing ratio at surface (kg kg-1), used for +! diagnosing the mixing ratio at 2 meter for coupled model +! Documentation for SNOTIME1 and SNOABL2 ????? +! What categories of arguments do these variables fall into ???? +! Documentation for RIBB ????? +! What category of argument does RIBB fall into ????? +! ---------------------------------------------------------------------- + + IMPLICIT NONE +! ---------------------------------------------------------------------- + integer, intent(in) :: iiloc, jjloc + INTEGER, INTENT(IN) :: ISICE +! ---------------------------------------------------------------------- + LOGICAL :: FRZGRA, SNOWNG + +! ---------------------------------------------------------------------- +! 1. CONFIGURATION INFORMATION (C): +! ---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: KZ + +! ---------------------------------------------------------------------- +! 2. LOGICAL: +! ---------------------------------------------------------------------- + + REAL, INTENT(IN) :: DT,DQSDT2,LWDN,PRCP, & + & Q2,Q2SAT,SFCPRS,SFCTMP, SNOALB, & + & SOLNET,TBOT,TH2,ZLVL,FFROZP + REAL, INTENT(OUT) :: EMBRD, ALBEDO + REAL, INTENT(INOUT):: CH,SNEQV,SNCOVR,SNOWH,T1,Z0BRD,EMISSI,ALB + REAL, INTENT(INOUT):: SNOTIME1 + REAL, INTENT(INOUT):: RIBB + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SLDPTH + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: ZSOIL + + REAL,INTENT(OUT) :: ETA_KINEMATIC,DEW,ESNOW,ETA, & + & ETP,FLX1,FLX2,FLX3,SHEAT,RUNOFF1, & + & SSOIL,SNOMLT,FDOWN,Q1 + REAL :: DF1,DSOIL,DTOT,FRCSNO,FRCSOI, & + & PRCP1,RCH,RR,RSNOW,SNDENS,SNCOND,SN_NEW, & + & T1V,T24,T2V,TH2V,TSNOW,Z0,PRCPF,RHO + +! ---------------------------------------------------------------------- +! DECLARATIONS - PARAMETERS +! ---------------------------------------------------------------------- + REAL, PARAMETER :: TFREEZ = 273.15 + REAL, PARAMETER :: LVH2O = 2.501E+6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + REAL, PARAMETER :: R = 287.04 + +! ---------------------------------------------------------------------- + iloc = iiloc + jloc = jjloc +! ---------------------------------------------------------------------- + ZSOIL (1) = - SLDPTH (1) + DO KZ = 2,NSOIL + ZSOIL (KZ) = - SLDPTH (KZ) + ZSOIL (KZ -1) + END DO + +! ---------------------------------------------------------------------- +! IF S.W.E. (SNEQV) BELOW THRESHOLD LOWER BOUND (0.10 M FOR GLACIAL +! ICE), THEN SET AT LOWER BOUND +! ---------------------------------------------------------------------- + IF ( SNEQV < 0.10 ) THEN + SNEQV = 0.10 + SNOWH = 0.50 + ENDIF +! ---------------------------------------------------------------------- +! IF INPUT SNOWPACK IS NONZERO, THEN COMPUTE SNOW DENSITY "SNDENS" AND +! SNOW THERMAL CONDUCTIVITY "SNCOND" +! ---------------------------------------------------------------------- + SNDENS = SNEQV / SNOWH + IF(SNDENS > 1.0) THEN + FATAL_ERROR( 'Physical snow depth is less than snow water equiv.' ) + ENDIF + + CALL CSNOW (SNCOND,SNDENS) +! ---------------------------------------------------------------------- +! DETERMINE IF IT'S PRECIPITATING AND WHAT KIND OF PRECIP IT IS. +! IF IT'S PRCPING AND THE AIR TEMP IS COLDER THAN 0 C, IT'S SNOWING! +! IF IT'S PRCPING AND THE AIR TEMP IS WARMER THAN 0 C, BUT THE GRND +! TEMP IS COLDER THAN 0 C, FREEZING RAIN IS PRESUMED TO BE FALLING. +! ---------------------------------------------------------------------- + + SNOWNG = .FALSE. + FRZGRA = .FALSE. + IF (PRCP > 0.0) THEN +! ---------------------------------------------------------------------- +! Snow defined when fraction of frozen precip (FFROZP) > 0.5, +! passed in from model microphysics. +! ---------------------------------------------------------------------- + IF (FFROZP .GT. 0.5) THEN + SNOWNG = .TRUE. + ELSE + IF (T1 <= TFREEZ) FRZGRA = .TRUE. + END IF + END IF +! ---------------------------------------------------------------------- +! IF EITHER PRCP FLAG IS SET, DETERMINE NEW SNOWFALL (CONVERTING PRCP +! RATE FROM KG M-2 S-1 TO A LIQUID EQUIV SNOW DEPTH IN METERS) AND ADD +! IT TO THE EXISTING SNOWPACK. +! NOTE THAT SINCE ALL PRECIP IS ADDED TO SNOWPACK, NO PRECIP INFILTRATES +! INTO THE SOIL SO THAT PRCP1 IS SET TO ZERO. +! ---------------------------------------------------------------------- + IF ( (SNOWNG) .OR. (FRZGRA) ) THEN + SN_NEW = PRCP * DT * 0.001 + SNEQV = SNEQV + SN_NEW + PRCPF = 0.0 + +! ---------------------------------------------------------------------- +! UPDATE SNOW DENSITY BASED ON NEW SNOWFALL, USING OLD AND NEW SNOW. +! UPDATE SNOW THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + CALL SNOW_NEW (SFCTMP,SN_NEW,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! kmh 09/04/2006 set Snow Density at 0.2 g/cm**3 +! for "cold permanent ice" or new "dry" snow +! if soil temperature less than 268.15 K, treat as typical +! Antarctic/Greenland snow firn +! ---------------------------------------------------------------------- + IF ( SNCOVR .GT. 0.99 ) THEN + IF ( STC(1) .LT. (TFREEZ - 5.) ) SNDENS = 0.2 + IF ( SNOWNG .AND. (T1.LT.273.) .AND. (SFCTMP.LT.273.) ) SNDENS=0.2 + ENDIF + + CALL CSNOW (SNCOND,SNDENS) + +! ---------------------------------------------------------------------- +! PRECIP IS LIQUID (RAIN), HENCE SAVE IN THE PRECIP VARIABLE THAT +! LATER CAN WHOLELY OR PARTIALLY INFILTRATE THE SOIL +! ---------------------------------------------------------------------- + ELSE + PRCPF = PRCP + ENDIF + +! ---------------------------------------------------------------------- +! DETERMINE SNOW FRACTIONAL COVERAGE. +! KWM: Set SNCOVR to 1.0 because SNUP is set small in VEGPARM.TBL, +! and SNEQV is at least 0.1 (as set above) +! ---------------------------------------------------------------------- + SNCOVR = 1.0 + +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ALBEDO MODIFICATION DUE TO SNOWDEPTH STATE. +! ---------------------------------------------------------------------- + + CALL ALCALC (ALB,SNOALB,EMBRD,T1,ALBEDO,EMISSI, & + & DT,SNOWNG,SNOTIME1) + +! ---------------------------------------------------------------------- +! THERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + DF1 = SNCOND + + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL + FRCSNO = SNOWH / DTOT + +! 1. HARMONIC MEAN (SERIES FLOW) +! DF1 = (SNCOND*DF1)/(FRCSOI*SNCOND+FRCSNO*DF1) + FRCSOI = DSOIL / DTOT + +! 3. GEOMETRIC MEAN (INTERMEDIATE BETWEEN HARMONIC AND ARITHMETIC MEAN) +! DF1 = (SNCOND**FRCSNO)*(DF1**FRCSOI) + DF1 = FRCSNO * SNCOND + FRCSOI * DF1 + +! ---------------------------------------------------------------------- +! CALCULATE SUBSURFACE HEAT FLUX, SSOIL, FROM FINAL THERMAL DIFFUSIVITY +! OF SURFACE MEDIUMS, DF1 ABOVE, AND SKIN TEMPERATURE AND TOP +! MID-LAYER SOIL TEMPERATURE +! ---------------------------------------------------------------------- + IF ( DTOT .GT. 2.*DSOIL ) then + DTOT = 2.*DSOIL + ENDIF + SSOIL = DF1 * ( T1 - STC(1) ) / DTOT + +! ---------------------------------------------------------------------- +! DETERMINE SURFACE ROUGHNESS OVER SNOWPACK USING SNOW CONDITION FROM +! THE PREVIOUS TIMESTEP. +! ---------------------------------------------------------------------- + + CALL SNOWZ0 (Z0,Z0BRD,SNOWH) + +! ---------------------------------------------------------------------- +! CALCULATE TOTAL DOWNWARD RADIATION (SOLAR PLUS LONGWAVE) NEEDED IN +! PENMAN EP SUBROUTINE THAT FOLLOWS +! ---------------------------------------------------------------------- + + FDOWN = SOLNET + LWDN + +! ---------------------------------------------------------------------- +! CALC VIRTUAL TEMPS AND VIRTUAL POTENTIAL TEMPS NEEDED BY SUBROUTINES +! PENMAN. +! ---------------------------------------------------------------------- + + T2V = SFCTMP * (1.0+ 0.61 * Q2 ) + RHO = SFCPRS / (RD * T2V) + RCH = RHO * 1004.6 * CH + T24 = SFCTMP * SFCTMP * SFCTMP * SFCTMP + +! ---------------------------------------------------------------------- +! CALL PENMAN SUBROUTINE TO CALCULATE POTENTIAL EVAPORATION (ETP), AND +! OTHER PARTIAL PRODUCTS AND SUMS SAVE IN COMMON/RITE FOR LATER +! CALCULATIONS. +! ---------------------------------------------------------------------- + + ! PENMAN returns ETP, FLX2, and RR + CALL PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI,T1) + + CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & + & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB) + +! ETA_KINEMATIC = ESNOW + ETA_KINEMATIC = ETP + +! ---------------------------------------------------------------------- +! Effective mixing ratio at grnd level (skin) +! ---------------------------------------------------------------------- + Q1=Q2+ETA_KINEMATIC*CP/RCH + +! ---------------------------------------------------------------------- +! DETERMINE SENSIBLE HEAT (H) IN ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) + +! ---------------------------------------------------------------------- +! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2) +! ---------------------------------------------------------------------- + ESNOW = ESNOW * LSUBS + ETP = ETP * LSUBS + IF (ETP .GT. 0.) THEN + ETA = ESNOW + ELSE + ETA = ETP + ENDIF + +! ---------------------------------------------------------------------- +! CONVERT THE SIGN OF SOIL HEAT FLUX SO THAT: +! SSOIL>0: WARM THE SURFACE (NIGHT TIME) +! SSOIL<0: COOL THE SURFACE (DAY TIME) +! ---------------------------------------------------------------------- + SSOIL = -1.0* SSOIL + +! ---------------------------------------------------------------------- +! FOR THE CASE OF GLACIAL-ICE, ADD ANY SNOWMELT DIRECTLY TO SURFACE +! RUNOFF (RUNOFF1) SINCE THERE IS NO SOIL MEDIUM +! ---------------------------------------------------------------------- + RUNOFF1 = SNOMLT / DT + +! ---------------------------------------------------------------------- + END SUBROUTINE SFLX_GLACIAL +! ---------------------------------------------------------------------- + + SUBROUTINE ALCALC (ALB,SNOALB,EMBRD,TSNOW,ALBEDO,EMISSI, & + & DT,SNOWNG,SNOTIME1) + +! ---------------------------------------------------------------------- +! CALCULATE ALBEDO INCLUDING SNOW EFFECT (0 -> 1) +! ALB SNOWFREE ALBEDO +! SNOALB MAXIMUM (DEEP) SNOW ALBEDO +! ALBEDO SURFACE ALBEDO INCLUDING SNOW EFFECT +! TSNOW SNOW SURFACE TEMPERATURE (K) +! ---------------------------------------------------------------------- + IMPLICIT NONE + +! ---------------------------------------------------------------------- +! SNOALB IS ARGUMENT REPRESENTING MAXIMUM ALBEDO OVER DEEP SNOW, +! AS PASSED INTO SFLX, AND ADAPTED FROM THE SATELLITE-BASED MAXIMUM +! SNOW ALBEDO FIELDS PROVIDED BY D. ROBINSON AND G. KUKLA +! (1985, JCAM, VOL 24, 402-411) +! ---------------------------------------------------------------------- + REAL, INTENT(IN) :: ALB, SNOALB, EMBRD, TSNOW + REAL, INTENT(IN) :: DT + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(INOUT) :: SNOTIME1 + REAL, INTENT(OUT) :: ALBEDO, EMISSI + REAL :: SNOALB2 + REAL :: TM,SNOALB1 + REAL, PARAMETER :: SNACCA=0.94,SNACCB=0.58,SNTHWA=0.82,SNTHWB=0.46 +! turn off vegetation effect +! ALBEDO = ALB + (1.0- (SHDFAC - SHDMIN))* SNCOVR * (SNOALB - ALB) +! ALBEDO = (1.0-SNCOVR)*ALB + SNCOVR*SNOALB !this is equivalent to below + ALBEDO = ALB + (SNOALB-ALB) + EMISSI = EMBRD + (EMISSI_S - EMBRD) + +! BASE FORMULATION (DICKINSON ET AL., 1986, COGLEY ET AL., 1990) +! IF (TSNOW.LE.263.16) THEN +! ALBEDO=SNOALB +! ELSE +! IF (TSNOW.LT.273.16) THEN +! TM=0.1*(TSNOW-263.16) +! SNOALB1=0.5*((0.9-0.2*(TM**3))+(0.8-0.16*(TM**3))) +! ELSE +! SNOALB1=0.67 +! IF(SNCOVR.GT.0.95) SNOALB1= 0.6 +! SNOALB1 = ALB + SNCOVR*(SNOALB-ALB) +! ENDIF +! ENDIF +! ALBEDO = ALB + SNCOVR*(SNOALB1-ALB) + +! ISBA FORMULATION (VERSEGHY, 1991; BAKER ET AL., 1990) +! SNOALB1 = SNOALB+COEF*(0.85-SNOALB) +! SNOALB2=SNOALB1 +!!m LSTSNW=LSTSNW+1 +! SNOTIME1 = SNOTIME1 + DT +! IF (SNOWNG) THEN +! SNOALB2=SNOALB +!!m LSTSNW=0 +! SNOTIME1 = 0.0 +! ELSE +! IF (TSNOW.LT.273.16) THEN +!! SNOALB2=SNOALB-0.008*LSTSNW*DT/86400 +!!m SNOALB2=SNOALB-0.008*SNOTIME1/86400 +! SNOALB2=(SNOALB2-0.65)*EXP(-0.05*DT/3600)+0.65 +!! SNOALB2=(ALBEDO-0.65)*EXP(-0.01*DT/3600)+0.65 +! ELSE +! SNOALB2=(SNOALB2-0.5)*EXP(-0.0005*DT/3600)+0.5 +!! SNOALB2=(SNOALB-0.5)*EXP(-0.24*LSTSNW*DT/86400)+0.5 +!!m SNOALB2=(SNOALB-0.5)*EXP(-0.24*SNOTIME1/86400)+0.5 +! ENDIF +! ENDIF +! +!! print*,'SNOALB2',SNOALB2,'ALBEDO',ALBEDO,'DT',DT +! ALBEDO = ALB + SNCOVR*(SNOALB2-ALB) +! IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2 +!!m LSTSNW1=LSTSNW +!! SNOTIME = SNOTIME1 + +! formulation by Livneh +! ---------------------------------------------------------------------- +! SNOALB IS CONSIDERED AS THE MAXIMUM SNOW ALBEDO FOR NEW SNOW, AT +! A VALUE OF 85%. SNOW ALBEDO CURVE DEFAULTS ARE FROM BRAS P.263. SHOULD +! NOT BE CHANGED EXCEPT FOR SERIOUS PROBLEMS WITH SNOW MELT. +! TO IMPLEMENT ACCUMULATIN PARAMETERS, SNACCA AND SNACCB, ASSERT THAT IT +! IS INDEED ACCUMULATION SEASON. I.E. THAT SNOW SURFACE TEMP IS BELOW +! ZERO AND THE DATE FALLS BETWEEN OCTOBER AND FEBRUARY +! ---------------------------------------------------------------------- + SNOALB1 = SNOALB+LVCOEF_DATA*(0.85-SNOALB) + SNOALB2=SNOALB1 +! ---------------- Initial LSTSNW -------------------------------------- + IF (SNOWNG) THEN + SNOTIME1 = 0. + ELSE + SNOTIME1=SNOTIME1+DT +! IF (TSNOW.LT.273.16) THEN + SNOALB2=SNOALB1*(SNACCA**((SNOTIME1/86400.0)**SNACCB)) +! ELSE +! SNOALB2 =SNOALB1*(SNTHWA**((SNOTIME1/86400.0)**SNTHWB)) +! ENDIF + ENDIF + + SNOALB2 = MAX ( SNOALB2, ALB ) + ALBEDO = ALB + (SNOALB2-ALB) + IF (ALBEDO .GT. SNOALB2) ALBEDO=SNOALB2 + +! IF (TSNOW.LT.273.16) THEN +! ALBEDO=SNOALB-0.008*DT/86400 +! ELSE +! ALBEDO=(SNOALB-0.5)*EXP(-0.24*DT/86400)+0.5 +! ENDIF + +! IF (ALBEDO > SNOALB) ALBEDO = SNOALB + +! ---------------------------------------------------------------------- + END SUBROUTINE ALCALC +! ---------------------------------------------------------------------- + + SUBROUTINE CSNOW (SNCOND,DSNOW) + +! ---------------------------------------------------------------------- +! CALCULATE SNOW TERMAL CONDUCTIVITY +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: DSNOW + REAL, INTENT(OUT) :: SNCOND + REAL :: C + REAL, PARAMETER :: UNIT = 0.11631 + +! ---------------------------------------------------------------------- +! SNCOND IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! CSNOW IN UNITS OF CAL/(CM*HR*C), RETURNED IN W/(M*C) +! BASIC VERSION IS DYACHKOVA EQUATION (1960), FOR RANGE 0.1-0.4 +! ---------------------------------------------------------------------- + C = 0.328*10** (2.25* DSNOW) +! CSNOW=UNIT*C + +! ---------------------------------------------------------------------- +! DE VAUX EQUATION (1933), IN RANGE 0.1-0.6 +! ---------------------------------------------------------------------- +! SNCOND=0.0293*(1.+100.*DSNOW**2) +! CSNOW=0.0293*(1.+100.*DSNOW**2) + +! ---------------------------------------------------------------------- +! E. ANDERSEN FROM FLERCHINGER +! ---------------------------------------------------------------------- +! SNCOND=0.021+2.51*DSNOW**2 +! CSNOW=0.021+2.51*DSNOW**2 + +! SNCOND = UNIT * C +! double snow thermal conductivity + SNCOND = 2.0 * UNIT * C + +! ---------------------------------------------------------------------- + END SUBROUTINE CSNOW +! ---------------------------------------------------------------------- + + SUBROUTINE HRTICE (RHSTS,STC,TBOT,NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION IN THE CASE OF SEA-ICE (ICE=1) OR GLACIAL +! ICE (ICE=-1). COMPUTE (PREPARE) THE MATRIX COEFFICIENTS FOR THE +! TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! +! (NOTE: THIS SUBROUTINE ONLY CALLED FOR SEA-ICE OR GLACIAL ICE, BUT +! NOT FOR NON-GLACIAL LAND (ICE = 0). +! ---------------------------------------------------------------------- + IMPLICIT NONE + + + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DF1,YY,ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STC, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, INTENT(IN) :: TBOT + INTEGER :: K + REAL :: DDZ,DDZ2,DENOM,DTSDZ,DTSDZ2,SSOIL,HCPCT + REAL :: DF1K,DF1N + REAL :: ZMD + REAL, PARAMETER :: ZBOT = -25.0 + +! ---------------------------------------------------------------------- +! SET A NOMINAL UNIVERSAL VALUE OF GLACIAL-ICE SPECIFIC HEAT CAPACITY, +! HCPCT = 2100.0*900.0 = 1.89000E+6 (SOURCE: BOB GRUMBINE, 2005) +! TBOT PASSED IN AS ARGUMENT, VALUE FROM GLOBAL DATA SET + ! + ! A least-squares fit for the four points provided by + ! Keith Hines for the Yen (1981) values for Antarctic + ! snow firn. + ! + HCPCT = 1.E6 * (0.8194 - 0.1309*0.5*ZSOIL(1)) + DF1K = DF1 + +! ---------------------------------------------------------------------- +! THE INPUT ARGUMENT DF1 IS A UNIVERSALLY CONSTANT VALUE OF SEA-ICE +! THERMAL DIFFUSIVITY, SET IN ROUTINE SNOPAC AS DF1 = 2.2. +! ---------------------------------------------------------------------- +! SET ICE PACK DEPTH. USE TBOT AS ICE PACK LOWER BOUNDARY TEMPERATURE +! (THAT OF UNFROZEN SEA WATER AT BOTTOM OF SEA ICE PACK). ASSUME ICE +! PACK IS OF N=NSOIL LAYERS SPANNING A UNIFORM CONSTANT ICE PACK +! THICKNESS AS DEFINED BY ZSOIL(NSOIL) IN ROUTINE SFLX. +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER +! ---------------------------------------------------------------------- + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT BTWN THE TOP AND 2ND SOIL LAYERS. +! RECALC/ADJUST THE SOIL HEAT FLUX. USE THE GRADIENT AND FLUX TO CALC +! RHSTS FOR THE TOP SOIL LAYER. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1/ (0.5 * ZSOIL (1) * ZSOIL (1) * HCPCT * & + & ZZ1) + DTSDZ = ( STC (1) - STC (2) ) / ( -0.5 * ZSOIL (2) ) + SSOIL = DF1 * ( STC (1) - YY ) / ( 0.5 * ZSOIL (1) * ZZ1 ) + +! ---------------------------------------------------------------------- +! INITIALIZE DDZ2 +! ---------------------------------------------------------------------- + RHSTS (1) = ( DF1 * DTSDZ - SSOIL ) / ( ZSOIL (1) * HCPCT ) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DF1K = DF1 + DF1N = DF1 + DO K = 2,NSOIL + + ZMD = 0.5 * (ZSOIL(K)+ZSOIL(K-1)) + ! For the land-ice case +! kmh 09/03/2006 use Yen (1981)'s values for Antarctic snow firn +! IF ( K .eq. 2 ) HCPCT = 0.855108E6 +! IF ( K .eq. 3 ) HCPCT = 0.922906E6 +! IF ( K .eq. 4 ) HCPCT = 1.009986E6 + + ! Least squares fit to the four points supplied by Keith Hines + ! from Yen (1981) for Antarctic snow firn. Not optimal, but + ! probably better than just a constant. + HCPCT = 1.E6 * ( 0.8194 - 0.1309*ZMD ) + +! IF ( K .eq. 2 ) DF1N = 0.345356 +! IF ( K .eq. 3 ) DF1N = 0.398777 +! IF ( K .eq. 4 ) DF1N = 0.472653 + + ! Least squares fit to the three points supplied by Keith Hines + ! from Yen (1981) for Antarctic snow firn. Not optimal, but + ! probably better than just a constant. + DF1N = 0.32333 - ( 0.10073 * ZMD ) +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER. +! ---------------------------------------------------------------------- + IF (K /= NSOIL) THEN + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + +! ---------------------------------------------------------------------- +! CALC THE MATRIX COEF, CI, AFTER CALC'NG ITS PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DTSDZ2 = ( STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + CI (K) = - DF1N * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K))*HCPCT) + +! ---------------------------------------------------------------------- +! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THE LOWEST LAYER. +! ---------------------------------------------------------------------- + ELSE + +! ---------------------------------------------------------------------- +! SET MATRIX COEF, CI TO ZERO. +! ---------------------------------------------------------------------- + DTSDZ2 = (STC (K) - TBOT)/ (.5 * (ZSOIL (K -1) + ZSOIL (K)) & + & - ZBOT) + CI (K) = 0. +! ---------------------------------------------------------------------- +! CALC RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + END IF + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + RHSTS (K) = ( DF1N * DTSDZ2- DF1K * DTSDZ ) / DENOM + AI (K) = - DF1K * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DTSDZ AND DDZ FOR LOOP TO NEXT SOIL LYR. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + DF1K = DF1N + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRTICE +! ---------------------------------------------------------------------- + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) + +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: STCIN + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI,BI,CI + REAL, DIMENSION(1:NSOIL) :: RHSTSin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DT + INTEGER :: K + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K) = RHSTS (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K) = RHSTS (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K) = STCIN (K) + CI (K) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,TH2,PRCP,FDOWN,T24,SSOIL, & + & Q2,Q2SAT,ETP,RCH,RR,SNOWNG,FRZGRA, & + & DQSDT2,FLX2,EMISSI,T1) + +! ---------------------------------------------------------------------- +! CALCULATE POTENTIAL EVAPORATION FOR THE CURRENT POINT. VARIOUS +! PARTIAL SUMS/PRODUCTS ARE ALSO CALCULATED AND PASSED BACK TO THE +! CALLING ROUTINE FOR LATER USE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA + REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP,Q2,Q2SAT,SSOIL,SFCPRS, & + & SFCTMP,TH2,EMISSI,T1,RCH,T24 + REAL, INTENT(OUT) :: ETP,FLX2,RR + + REAL :: A, DELTA, FNET,RAD,ELCP1,LVS,EPSCA + + REAL, PARAMETER :: ELCP = 2.4888E+3, LSUBC = 2.501000E+6 + REAL, PARAMETER :: LSUBS = 2.83E+6 + +! ---------------------------------------------------------------------- +! PREPARE PARTIAL QUANTITIES FOR PENMAN EQUATION. +! ---------------------------------------------------------------------- + IF ( T1 > 273.15 ) THEN + ELCP1 = ELCP + LVS = LSUBC + ELSE + ELCP1 = ELCP*LSUBS/LSUBC + LVS = LSUBS + ENDIF + DELTA = ELCP1 * DQSDT2 + A = ELCP1 * (Q2SAT - Q2) + RR = EMISSI*T24 * 6.48E-8 / (SFCPRS * CH) + 1.0 + +! ---------------------------------------------------------------------- +! ADJUST THE PARTIAL SUMS / PRODUCTS WITH THE LATENT HEAT +! EFFECTS CAUSED BY FALLING PRECIPITATION. +! ---------------------------------------------------------------------- + IF (.NOT. SNOWNG) THEN + IF (PRCP > 0.0) RR = RR + CPH2O * PRCP / RCH + ELSE + RR = RR + CPICE * PRCP / RCH + END IF + +! ---------------------------------------------------------------------- +! INCLUDE THE LATENT HEAT EFFECTS OF FREEZING RAIN CONVERTING TO ICE ON +! IMPACT IN THE CALCULATION OF FLX2 AND FNET. +! ---------------------------------------------------------------------- + IF (FRZGRA) THEN + FLX2 = - LSUBF * PRCP + ELSE + FLX2 = 0.0 + ENDIF + FNET = FDOWN - ( EMISSI * SIGMA * T24 ) - SSOIL - FLX2 + +! ---------------------------------------------------------------------- +! FINISH PENMAN EQUATION CALCULATIONS. +! ---------------------------------------------------------------------- + RAD = FNET / RCH + TH2 - SFCTMP + EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) + ETP = EPSCA * RCH / LVS + +! ---------------------------------------------------------------------- + END SUBROUTINE PENMAN +! ---------------------------------------------------------------------- + + SUBROUTINE SHFLX (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + REAL, INTENT(IN) :: DF1,DT,TBOT,YY, ZZ1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + INTEGER :: I + REAL, PARAMETER :: T0 = 273.15 + +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + CALL HRTICE (RHSTS,STC,TBOT, NSOIL,ZSOIL,YY,ZZ1,DF1,AI,BI,CI) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + DO I = 1,NSOIL + STC (I) = STCF (I) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,NSOIL,DT,DF1, & + & Q2,T1,SFCTMP,T24,TH2,FDOWN,SSOIL,STC, & + & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & + & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB) + +! ---------------------------------------------------------------------- +! CALCULATE SOIL MOISTURE AND HEAT FLUX VALUES & UPDATE SOIL MOISTURE +! CONTENT AND SOIL HEAT CONTENT VALUES FOR THE CASE WHEN A SNOW PACK IS +! PRESENT. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + LOGICAL, INTENT(IN) :: SNOWNG + REAL, INTENT(IN) :: DF1,DT,FDOWN,PRCP,Q2,RCH,RR,SFCPRS,SFCTMP, & + & T24,TBOT,TH2,EMISSI + REAL, INTENT(INOUT) :: SNEQV,FLX2,PRCPF,SNOWH,SNDENS,T1,RIBB,ETP + REAL, INTENT(OUT) :: DEW,ESNOW,FLX1,FLX3,SSOIL,SNOMLT + REAL, DIMENSION(1:NSOIL),INTENT(IN) :: ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: ET1 + INTEGER :: K + REAL :: DENOM,DSOIL,DTOT,ESDFLX,ETA, & + & ESNOW1,ESNOW2,ETA1,ETP1,ETP2, & + & ETP3,ETANRG,EX, & + & FRCSNO,FRCSOI,PRCP1,QSAT,RSNOW,SEH, & + & SNCOND,T12,T12A,T12B,T14,YY,ZZ1 + + REAL, PARAMETER :: ESDMIN = 1.E-6, LSUBC = 2.501000E+6, & + & LSUBS = 2.83E+6, TFREEZ = 273.15, & + & SNOEXP = 2.0 + +! ---------------------------------------------------------------------- +! FOR GLACIAL-ICE, SNOWCOVER FRACTION = 1.0, AND SUBLIMATION IS AT THE +! POTENTIAL RATE. +! ---------------------------------------------------------------------- +! INITIALIZE EVAP TERMS. +! ---------------------------------------------------------------------- +! conversions: +! ESNOW [KG M-2 S-1] +! ESDFLX [KG M-2 S-1] .le. ESNOW +! ESNOW1 [M S-1] +! ESNOW2 [M] +! ETP [KG M-2 S-1] +! ETP1 [M S-1] +! ETP2 [M] +! ---------------------------------------------------------------------- + SNOMLT = 0.0 + DEW = 0. + ESNOW = 0. + ESNOW1 = 0. + ESNOW2 = 0. + +! ---------------------------------------------------------------------- +! CONVERT POTENTIAL EVAP (ETP) FROM KG M-2 S-1 TO ETP1 IN M S-1 +! ---------------------------------------------------------------------- + PRCP1 = PRCPF *0.001 +! ---------------------------------------------------------------------- +! IF ETP<0 (DOWNWARD) THEN DEWFALL (=FROSTFALL IN THIS CASE). +! ---------------------------------------------------------------------- + IF (ETP <= 0.0) THEN + IF ( ( RIBB >= 0.1 ) .AND. ( FDOWN > 150.0 ) ) THEN + ETP=(MIN(ETP*(1.0-RIBB),0.)/0.980 + ETP*(0.980-1.0))/0.980 + ENDIF + ETP1 = ETP * 0.001 + DEW = -ETP1 + ESNOW2 = ETP1*DT + ETANRG = ETP*LSUBS + ELSE + ETP1 = ETP * 0.001 + ESNOW = ETP + ESNOW1 = ESNOW*0.001 + ESNOW2 = ESNOW1*DT + ETANRG = ESNOW*LSUBS + END IF + +! ---------------------------------------------------------------------- +! IF PRECIP IS FALLING, CALCULATE HEAT FLUX FROM SNOW SFC TO NEWLY +! ACCUMULATING PRECIP. NOTE THAT THIS REFLECTS THE FLUX APPROPRIATE FOR +! THE NOT-YET-UPDATED SKIN TEMPERATURE (T1). ASSUMES TEMPERATURE OF THE +! SNOWFALL STRIKING THE GROUND IS =SFCTMP (LOWEST MODEL LEVEL AIR TEMP). +! ---------------------------------------------------------------------- + FLX1 = 0.0 + IF (SNOWNG) THEN + FLX1 = CPICE * PRCP * (T1- SFCTMP) + ELSE + IF (PRCP > 0.0) FLX1 = CPH2O * PRCP * (T1- SFCTMP) + END IF +! ---------------------------------------------------------------------- +! CALCULATE AN 'EFFECTIVE SNOW-GRND SFC TEMP' (T12) BASED ON HEAT FLUXES +! BETWEEN THE SNOW PACK AND THE SOIL AND ON NET RADIATION. +! INCLUDE FLX1 (PRECIP-SNOW SFC) AND FLX2 (FREEZING RAIN LATENT HEAT) +! FLUXES. FLX1 FROM ABOVE, FLX2 BROUGHT IN VIA COMMOM BLOCK RITE. +! FLX2 REFLECTS FREEZING RAIN LATENT HEAT FLUX USING T1 CALCULATED IN +! PENMAN. +! ---------------------------------------------------------------------- + DSOIL = - (0.5 * ZSOIL (1)) + DTOT = SNOWH + DSOIL + DENOM = 1.0+ DF1 / (DTOT * RR * RCH) + T12A = ( (FDOWN - FLX1- FLX2- EMISSI * SIGMA * T24)/ RCH & + + TH2- SFCTMP - ETANRG / RCH ) / RR + T12B = DF1 * STC (1) / (DTOT * RR * RCH) + + T12 = (SFCTMP + T12A + T12B) / DENOM + IF (T12 <= TFREEZ) THEN +! ---------------------------------------------------------------------- +! SUB-FREEZING BLOCK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS AT OR BELOW FREEZING, NO SNOW +! MELT WILL OCCUR. SET THE SKIN TEMP TO THIS EFFECTIVE TEMP. REDUCE +! (BY SUBLIMINATION ) OR INCREASE (BY FROST) THE DEPTH OF THE SNOWPACK, +! DEPENDING ON SIGN OF ETP. +! UPDATE SOIL HEAT FLUX (SSOIL) USING NEW SKIN TEMPERATURE (T1) +! SINCE NO SNOWMELT, SET ACCUMULATED SNOWMELT TO ZERO, SET 'EFFECTIVE' +! PRECIP FROM SNOWMELT TO ZERO, SET PHASE-CHANGE HEAT FLUX FROM SNOWMELT +! TO ZERO. +! ---------------------------------------------------------------------- + T1 = T12 + SSOIL = DF1 * (T1- STC (1)) / DTOT + SNEQV = MAX(0.0, SNEQV-ESNOW2) + FLX3 = 0.0 + EX = 0.0 + SNOMLT = 0.0 + ELSE +! ---------------------------------------------------------------------- +! ABOVE FREEZING BLOCK +! ---------------------------------------------------------------------- +! IF THE 'EFFECTIVE SNOW-GRND SFC TEMP' IS ABOVE FREEZING, SNOW MELT +! WILL OCCUR. CALL THE SNOW MELT RATE,EX AND AMT, SNOMLT. REVISE THE +! EFFECTIVE SNOW DEPTH. REVISE THE SKIN TEMP BECAUSE IT WOULD HAVE CHGD +! DUE TO THE LATENT HEAT RELEASED BY THE MELTING. CALC THE LATENT HEAT +! RELEASED, FLX3. SET THE EFFECTIVE PRECIP, PRCP1 TO THE SNOW MELT RATE, +! EX FOR USE IN SMFLX. ADJUSTMENT TO T1 TO ACCOUNT FOR SNOW PATCHES. +! CALCULATE QSAT VALID AT FREEZING POINT. NOTE THAT ESAT (SATURATION +! VAPOR PRESSURE) VALUE OF 6.11E+2 USED HERE IS THAT VALID AT FRZZING +! POINT. NOTE THAT ETP FROM CALL PENMAN IN SFLX IS IGNORED HERE IN +! FAVOR OF BULK ETP OVER 'OPEN WATER' AT FREEZING TEMP. +! UPDATE SOIL HEAT FLUX (S) USING NEW SKIN TEMPERATURE (T1) +! ---------------------------------------------------------------------- + T1 = TFREEZ + IF ( DTOT .GT. 2.0*DSOIL ) THEN + DTOT = 2.0*DSOIL + ENDIF + SSOIL = DF1 * (T1- STC (1)) / DTOT + IF (SNEQV-ESNOW2 <= ESDMIN) THEN + SNEQV = 0.0 + EX = 0.0 + SNOMLT = 0.0 + FLX3 = 0.0 +! ---------------------------------------------------------------------- +! SUBLIMATION LESS THAN DEPTH OF SNOWPACK +! SNOWPACK (SNEQV) REDUCED BY ESNOW2 (DEPTH OF SUBLIMATED SNOW) +! ---------------------------------------------------------------------- + ELSE + SNEQV = SNEQV-ESNOW2 + ETP3 = ETP * LSUBC + SEH = RCH * (T1- TH2) + T14 = ( T1 * T1 ) * ( T1 * T1 ) + FLX3 = FDOWN - FLX1- FLX2- EMISSI*SIGMA * T14- SSOIL - SEH - ETANRG + IF (FLX3 <= 0.0) FLX3 = 0.0 + EX = FLX3*0.001/ LSUBF + SNOMLT = EX * DT +! ---------------------------------------------------------------------- +! ESDMIN REPRESENTS A SNOWPACK DEPTH THRESHOLD VALUE BELOW WHICH WE +! CHOOSE NOT TO RETAIN ANY SNOWPACK, AND INSTEAD INCLUDE IT IN SNOWMELT. +! ---------------------------------------------------------------------- + IF (SNEQV- SNOMLT >= ESDMIN) THEN + SNEQV = SNEQV- SNOMLT + ELSE +! ---------------------------------------------------------------------- +! SNOWMELT EXCEEDS SNOW DEPTH +! ---------------------------------------------------------------------- + EX = SNEQV / DT + FLX3 = EX *1000.0* LSUBF + SNOMLT = SNEQV + + SNEQV = 0.0 + ENDIF + ENDIF + +! ---------------------------------------------------------------------- +! FOR GLACIAL ICE, THE SNOWMELT WILL BE ADDED TO SUBSURFACE +! RUNOFF/BASEFLOW LATER NEAR THE END OF SFLX (AFTER RETURN FROM CALL TO +! SUBROUTINE SNOPAC) +! ---------------------------------------------------------------------- + + ENDIF + +! ---------------------------------------------------------------------- +! BEFORE CALL SHFLX IN THIS SNOWPACK CASE, SET ZZ1 AND YY ARGUMENTS TO +! SPECIAL VALUES THAT ENSURE THAT GROUND HEAT FLUX CALCULATED IN SHFLX +! MATCHES THAT ALREADY COMPUTED FOR BELOW THE SNOWPACK, THUS THE SFC +! HEAT FLUX TO BE COMPUTED IN SHFLX WILL EFFECTIVELY BE THE FLUX AT THE +! SNOW TOP SURFACE. +! ---------------------------------------------------------------------- + ZZ1 = 1.0 + YY = STC (1) -0.5* SSOIL * ZSOIL (1)* ZZ1/ DF1 + +! ---------------------------------------------------------------------- +! SHFLX WILL CALC/UPDATE THE SOIL TEMPS. +! ---------------------------------------------------------------------- + CALL SHFLX (STC,NSOIL,DT,YY,ZZ1,ZSOIL,TBOT,DF1) + +! ---------------------------------------------------------------------- +! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS +! ASSUMED TO BE THE SOIL TEMPERTURE AT THE TOP OF THE SOIL COLUMN. +! ---------------------------------------------------------------------- + IF (SNEQV .GE. 0.10) THEN + CALL SNOWPACK (SNEQV,DT,SNOWH,SNDENS,T1,YY) + ELSE + SNEQV = 0.10 + SNOWH = 0.50 +!KWM???? SNDENS = +!KWM???? SNCOND = + ENDIF +! ---------------------------------------------------------------------- + END SUBROUTINE SNOPAC +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWPACK (SNEQV,DTSEC,SNOWH,SNDENS,TSNOW,TSOIL) + +! ---------------------------------------------------------------------- +! CALCULATE COMPACTION OF SNOWPACK UNDER CONDITIONS OF INCREASING SNOW +! DENSITY, AS OBTAINED FROM AN APPROXIMATE SOLUTION OF E. ANDERSON'S +! DIFFERENTIAL EQUATION (3.29), NOAA TECHNICAL REPORT NWS 19, BY VICTOR +! KOREN, 03/25/95. +! ---------------------------------------------------------------------- +! SNEQV WATER EQUIVALENT OF SNOW (M) +! DTSEC TIME STEP (SEC) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! TSNOW SNOW SURFACE TEMPERATURE (K) +! TSOIL SOIL SURFACE TEMPERATURE (K) + +! SUBROUTINE WILL RETURN NEW VALUES OF SNOWH AND SNDENS +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER :: IPOL, J + REAL, INTENT(IN) :: SNEQV, DTSEC,TSNOW,TSOIL + REAL, INTENT(INOUT) :: SNOWH, SNDENS + REAL :: BFAC,DSX,DTHR,DW,SNOWHC,PEXP, & + TAVGC,TSNOWC,TSOILC,ESDC,ESDCX + REAL, PARAMETER :: C1 = 0.01, C2 = 21.0, G = 9.81, & + KN = 4000.0 +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH *100. + ESDC = SNEQV *100. + DTHR = DTSEC /3600. + TSNOWC = TSNOW -273.15 + TSOILC = TSOIL -273.15 + +! ---------------------------------------------------------------------- +! CALCULATING OF AVERAGE TEMPERATURE OF SNOW PACK +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! CALCULATING OF SNOW DEPTH AND DENSITY AS A RESULT OF COMPACTION +! SNDENS=DS0*(EXP(BFAC*SNEQV)-1.)/(BFAC*SNEQV) +! BFAC=DTHR*C1*EXP(0.08*TAVGC-C2*DS0) +! NOTE: BFAC*SNEQV IN SNDENS EQN ABOVE HAS TO BE CAREFULLY TREATED +! NUMERICALLY BELOW: +! C1 IS THE FRACTIONAL INCREASE IN DENSITY (1/(CM*HR)) +! C2 IS A CONSTANT (CM3/G) KOJIMA ESTIMATED AS 21 CMS/G +! ---------------------------------------------------------------------- + TAVGC = 0.5* (TSNOWC + TSOILC) + IF (ESDC > 1.E-2) THEN + ESDCX = ESDC + ELSE + ESDCX = 1.E-2 + END IF + +! DSX = SNDENS*((DEXP(BFAC*ESDC)-1.)/(BFAC*ESDC)) +! ---------------------------------------------------------------------- +! THE FUNCTION OF THE FORM (e**x-1)/x IMBEDDED IN ABOVE EXPRESSION +! FOR DSX WAS CAUSING NUMERICAL DIFFICULTIES WHEN THE DENOMINATOR "x" +! (I.E. BFAC*ESDC) BECAME ZERO OR APPROACHED ZERO (DESPITE THE FACT THAT +! THE ANALYTICAL FUNCTION (e**x-1)/x HAS A WELL DEFINED LIMIT AS +! "x" APPROACHES ZERO), HENCE BELOW WE REPLACE THE (e**x-1)/x +! EXPRESSION WITH AN EQUIVALENT, NUMERICALLY WELL-BEHAVED +! POLYNOMIAL EXPANSION. + +! NUMBER OF TERMS OF POLYNOMIAL EXPANSION, AND HENCE ITS ACCURACY, +! IS GOVERNED BY ITERATION LIMIT "IPOL". +! IPOL GREATER THAN 9 ONLY MAKES A DIFFERENCE ON DOUBLE +! PRECISION (RELATIVE ERRORS GIVEN IN PERCENT %). +! IPOL=9, FOR REL.ERROR <~ 1.6 E-6 % (8 SIGNIFICANT DIGITS) +! IPOL=8, FOR REL.ERROR <~ 1.8 E-5 % (7 SIGNIFICANT DIGITS) +! IPOL=7, FOR REL.ERROR <~ 1.8 E-4 % ... +! ---------------------------------------------------------------------- + BFAC = DTHR * C1* EXP (0.08* TAVGC - C2* SNDENS) + IPOL = 4 + PEXP = 0. +! PEXP = (1. + PEXP)*BFAC*ESDC/REAL(J+1) + DO J = IPOL,1, -1 + PEXP = (1. + PEXP)* BFAC * ESDCX / REAL (J +1) + END DO + + PEXP = PEXP + 1. +! ---------------------------------------------------------------------- +! ABOVE LINE ENDS POLYNOMIAL SUBSTITUTION +! ---------------------------------------------------------------------- +! END OF KOREAN FORMULATION + +! BASE FORMULATION (COGLEY ET AL., 1990) +! CONVERT DENSITY FROM G/CM3 TO KG/M3 +! DSM=SNDENS*1000.0 + +! DSX=DSM+DTSEC*0.5*DSM*G*SNEQV/ +! & (1E7*EXP(-0.02*DSM+KN/(TAVGC+273.16)-14.643)) + +! & CONVERT DENSITY FROM KG/M3 TO G/CM3 +! DSX=DSX/1000.0 + +! END OF COGLEY ET AL. FORMULATION + +! ---------------------------------------------------------------------- +! SET UPPER/LOWER LIMIT ON SNOW DENSITY +! ---------------------------------------------------------------------- + DSX = SNDENS * (PEXP) + IF (DSX > 0.40) DSX = 0.40 + IF (DSX < 0.05) DSX = 0.05 +! ---------------------------------------------------------------------- +! UPDATE OF SNOW DEPTH AND DENSITY DEPENDING ON LIQUID WATER DURING +! SNOWMELT. ASSUMED THAT 13% OF LIQUID WATER CAN BE STORED IN SNOW PER +! DAY DURING SNOWMELT TILL SNOW DENSITY 0.40. +! ---------------------------------------------------------------------- + SNDENS = DSX + IF (TSNOWC >= 0.) THEN + DW = 0.13* DTHR /24. + SNDENS = SNDENS * (1. - DW) + DW + IF (SNDENS >= 0.40) SNDENS = 0.40 +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH (CM) FROM SNOW WATER EQUIVALENT AND SNOW DENSITY. +! CHANGE SNOW DEPTH UNITS TO METERS +! ---------------------------------------------------------------------- + END IF + SNOWHC = ESDC / SNDENS + SNOWH = SNOWHC * 0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWPACK +! ---------------------------------------------------------------------- + + SUBROUTINE SNOWZ0 (Z0, Z0BRD, SNOWH) +! ---------------------------------------------------------------------- +! CALCULATE TOTAL ROUGHNESS LENGTH OVER SNOW +! Z0 ROUGHNESS LENGTH (m) +! Z0S SNOW ROUGHNESS LENGTH:=0.001 (m) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: Z0BRD + REAL, INTENT(OUT) :: Z0 + REAL, PARAMETER :: Z0S=0.001 + REAL, INTENT(IN) :: SNOWH + REAL :: BURIAL + REAL :: Z0EFF + + BURIAL = 7.0*Z0BRD - SNOWH + IF(BURIAL.LE.0.0007) THEN + Z0EFF = Z0S + ELSE + Z0EFF = BURIAL/7.0 + ENDIF + + Z0 = Z0EFF + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWZ0 +! ---------------------------------------------------------------------- + + SUBROUTINE SNOW_NEW (TEMP,NEWSN,SNOWH,SNDENS) + +! ---------------------------------------------------------------------- +! CALCULATE SNOW DEPTH AND DENSITY TO ACCOUNT FOR THE NEW SNOWFALL. +! UPDATED VALUES OF SNOW DEPTH AND DENSITY ARE RETURNED. + +! TEMP AIR TEMPERATURE (K) +! NEWSN NEW SNOWFALL (M) +! SNOWH SNOW DEPTH (M) +! SNDENS SNOW DENSITY (G/CM3=DIMENSIONLESS FRACTION OF H2O DENSITY) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: NEWSN, TEMP + REAL, INTENT(INOUT) :: SNDENS, SNOWH + REAL :: DSNEW, HNEWC, SNOWHC,NEWSNC,TEMPC + +! ---------------------------------------------------------------------- +! CALCULATING NEW SNOWFALL DENSITY DEPENDING ON TEMPERATURE +! EQUATION FROM GOTTLIB L. 'A GENERAL RUNOFF MODEL FOR SNOWCOVERED +! AND GLACIERIZED BASIN', 6TH NORDIC HYDROLOGICAL CONFERENCE, +! VEMADOLEN, SWEDEN, 1980, 172-177PP. +!----------------------------------------------------------------------- + TEMPC = TEMP - 273.15 + IF ( TEMPC <= -15. ) THEN + DSNEW = 0.05 + ELSE + DSNEW = 0.05 + 0.0017 * ( TEMPC + 15. ) ** 1.5 + ENDIF + +! ---------------------------------------------------------------------- +! CONVERSION INTO SIMULATION UNITS +! ---------------------------------------------------------------------- + SNOWHC = SNOWH * 100. + NEWSNC = NEWSN * 100. + +! ---------------------------------------------------------------------- +! ADJUSTMENT OF SNOW DENSITY DEPENDING ON NEW SNOWFALL +! ---------------------------------------------------------------------- + HNEWC = NEWSNC / DSNEW + IF ( SNOWHC + HNEWC < 1.0E-3 ) THEN + SNDENS = MAX ( DSNEW , SNDENS ) + ELSE + SNDENS = ( SNOWHC * SNDENS + HNEWC * DSNEW ) / ( SNOWHC + HNEWC ) + ENDIF + SNOWHC = SNOWHC + HNEWC + SNOWH = SNOWHC * 0.01 + +! ---------------------------------------------------------------------- + END SUBROUTINE SNOW_NEW +! ---------------------------------------------------------------------- + +END MODULE module_sf_noahlsm_glacial_only diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F index 010f54dbf6..2b3ba578f0 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclay.F @@ -1,12 +1,3 @@ -!================================================================================================================= -!module_sf_sfclay.F was originally copied from ./phys/module_sf_sfclay.F from WRF version 3.8.1. -!Laura D. Fowler (laura@ucar.edu) / 2016-10-26. - -!modifications to sourcecode for MPAS: -! * added the actual size of each cell in the calculation of the Mahrt and Sun low-resolution correction. -! Laura D. Fowler (laura@ucar.edu) / 2016-10-26. - -!================================================================================================================= !WRF:MODEL_LAYER:PHYSICS ! MODULE module_sf_sfclay @@ -33,11 +24,8 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & 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,scm_force_flux & -#if defined(mpas) - ,dxCell & -#endif - ) + ustm,ck,cka,cd,cda, & + isftcflx,iz0tlnd,scm_force_flux) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -150,14 +138,12 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & XLAND, & TSK -! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: REGIME, & HFX, & QFX, & LH, & MOL,RMOL -!m the following 5 are change to memory size ! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: GZ1OZ0,WSPD,BR, & @@ -185,8 +171,10 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: & QGH + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: DX REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda @@ -197,19 +185,15 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX -#if defined(mpas) - real,intent(in),dimension(ims:ime,jms:jme),optional:: dxCell - real,intent(inout),dimension(ims:ime,jms:jme):: qsfc - real,intent(out),dimension(ims:ime,jms:jme) :: u10,v10,th2,t2,q2 -#else + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT ) :: QSFC + REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & V10, & TH2, & T2, & - Q2, & - QSFC -#endif + Q2 ! LOCAL VARS @@ -221,9 +205,16 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( its:ite ) :: dz8w1d + REAL, DIMENSION( its:ite ) :: DX2D + INTEGER :: I,J DO J=jts,jte + + DO i=its,ite + DX2D(i)=DX(i,j) + ENDDO + DO i=its,ite dz8w1d(I) = dz8w(i,1,j) ENDDO @@ -249,17 +240,13 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j), & Q2(ims,j),FLHC(ims,j),FLQC(ims,j),QGH(ims,j), & QSFC(ims,j),LH(ims,j), & - GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & + GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX2D, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT, & P1000mb, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & -#if defined(mpas) - ,isftcflx,iz0tlnd,scm_force_flux, & - USTM(ims,j),CK(ims,j),CKA(ims,j), & - CD(ims,j),CDA(ims,j),dxCell(ims,j) & -#elif ( EM_CORE == 1 ) +#if ( ( EM_CORE == 1 ) || ( defined(mpas) ) ) ,isftcflx,iz0tlnd,scm_force_flux, & USTM(ims,j),CK(ims,j),CKA(ims,j), & CD(ims,j),CDA(ims,j) & @@ -285,11 +272,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & isftcflx, iz0tlnd, scm_force_flux, & -#if defined(mpas) - ustm,ck,cka,cd,cda,dxCell ) -#else ustm,ck,cka,cd,cda ) -#endif !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -341,14 +324,15 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL, DIMENSION( ims:ime ) , & INTENT(INOUT) :: & - QGH + QSFC,QGH REAL, DIMENSION( ims:ime ) , & INTENT(OUT) :: U10,V10, & - TH2,T2,Q2,QSFC,LH + TH2,T2,Q2,LH - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX + REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV + + REAL, DIMENSION( its:ite ), INTENT(IN ) :: DX ! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY REAL, DIMENSION( its:ite ), INTENT(IN ) :: dz8w1d @@ -359,10 +343,6 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & P1D, & T1D -#if defined(mpas) - real,intent(in),dimension(ims:ime),optional:: dxCell -#endif - REAL, OPTIONAL, DIMENSION( ims:ime ) , & INTENT(OUT) :: ck,cka,cd,cda REAL, OPTIONAL, DIMENSION( ims:ime ) , & @@ -539,14 +519,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & VCONV = SQRT(DTHVM) endif ! Mahrt and Sun low-res correction -!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 -!MPAS specific end. + VSGD = 0.32 * (max(dx(i)/5000.-1.,0.))**.33 WSPD(I)=SQRT(WSPD(I)*WSPD(I)+VCONV*VCONV+vsgd*vsgd) WSPD(I)=AMAX1(WSPD(I),0.1) BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) @@ -796,14 +769,19 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & Cda(I)=(karman/psix)*(karman/psix) ENDIF IF ( PRESENT(IZ0TLND) ) THEN - IF ( IZ0TLND.EQ.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN + IF ( IZ0TLND.GE.1 .AND. (XLAND(I)-1.5).LE.0. ) THEN ZL=ZNT(I) ! CZIL RELATED CHANGES FOR LAND VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 RESTAR=UST(I)*ZL/VISC -! Modify CZIL according to Chen & Zhang, 2009 +! Modify CZIL according to Chen & Zhang, 2009 if iz0tlnd = 1 +! If iz0tlnd = 2, use traditional value - CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) + IF ( IZ0TLND.EQ.1 ) THEN + CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) + ELSE IF ( IZ0TLND.EQ.2 ) THEN + CZIL = 0.1 + END IF PSIT=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) PSIQ=GZ1OZ0(I)-PSIH(I)+CZIL*KARMAN*SQRT(RESTAR) @@ -863,6 +841,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! ZNT(I)=CZO*UST(I)*UST(I)/G+OZO ! Since V3.7 (ref: EC Physics document for Cy36r1) ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) +! V3.9: Add limit as in isftcflx = 1,2 + ZNT(I)=MIN(ZNT(I),2.85e-3) ! COARE 3.5 (Edson et al. 2013) ! CZC = 0.0017*WSPD(I)-0.005 ! CZC = min(CZC,0.028) diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F new file mode 100644 index 0000000000..ac70882989 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_sfclayrev.F @@ -0,0 +1,281 @@ +!================================================================================================================= + module module_sf_sfclayrev + use mpas_kind_types,only: kind_phys => RKIND + + use sf_sfclayrev,only: sf_sfclayrev_run + use sf_sfclayrev_pre,only: sf_sfclayrev_pre_run + + implicit none + private + public:: sfclayrev + + + contains + + +!================================================================================================================= + subroutine sfclayrev(u3d,v3d,t3d,qv3d,p3d,dz8w, & + cp,g,rovcp,r,xlv,psfc,chs,chs2,cqs2,cpm, & + znt,ust,pblh,mavail,zol,mol,regime,psim,psih, & + fm,fh, & + xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & + u10,v10,th2,t2,q2, & + gz1oz0,wspd,br,isfflx,dx, & + svp1,svp2,svp3,svpt0,ep1,ep2, & + karman,p1000mb,lakemask, & + 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, & + shalwater_z0,water_depth, & + scm_force_flux,errmsg,errflg) +!================================================================================================================= + +!--- 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):: isfflx + integer,intent(in):: shalwater_z0 + integer,intent(in),optional:: isftcflx, iz0tlnd + integer,intent(in),optional:: scm_force_flux + + real(kind=kind_phys),intent(in):: svp1,svp2,svp3,svpt0 + real(kind=kind_phys),intent(in):: ep1,ep2,karman + real(kind=kind_phys),intent(in):: p1000mb + real(kind=kind_phys),intent(in):: cp,g,rovcp,r,xlv + + real(kind=kind_phys),intent(in),dimension(ims:ime,jms:jme):: & + dx, & + mavail, & + pblh, & + psfc, & + tsk, & + xland, & + lakemask, & + water_depth + + real(kind=kind_phys),intent(in),dimension(ims:ime,kms:kme,jms:jme):: & + dz8w, & + qv3d, & + p3d, & + t3d, & + u3d, & + v3d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme):: & + lh, & + u10, & + v10, & + th2, & + t2, & + q2 + + real(kind=kind_phys),intent(out),dimension(ims:ime,jms:jme),optional:: & + ck, & + cka, & + cd, & + cda + +!--- inout arguments: + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme):: & + regime, & + hfx, & + qfx, & + qsfc, & + mol, & + rmol, & + gz1oz0, & + wspd, & + br, & + psim, & + psih, & + fm, & + fh, & + znt, & + zol, & + ust, & + cpm, & + chs2, & + cqs2, & + chs, & + flhc, & + flqc, & + qgh + + real(kind=kind_phys),intent(inout),dimension(ims:ime,jms:jme),optional:: & + ustm + +!--- local variables and arrays: + logical:: l_isfflx + logical:: l_shalwater_z0 + logical:: l_scm_force_flux + + integer:: i,j,k + real(kind=kind_phys),dimension(its:ite):: dz1d,u1d,v1d,qv1d,p1d,t1d + + real(kind=kind_phys),dimension(its:ite):: & + dx_hv,mavail_hv,pblh_hv,psfc_hv,tsk_hv,xland_hv,water_depth_hv,lakemask_hv + real(kind=kind_phys),dimension(its:ite,kts:kte):: & + dz_hv,u_hv,v_hv,qv_hv,p_hv,t_hv + + real(kind=kind_phys),dimension(its:ite):: & + lh_hv,u10_hv,v10_hv,th2_hv,t2_hv,q2_hv + real(kind=kind_phys),dimension(its:ite):: & + ck_hv,cka_hv,cd_hv,cda_hv + + real(kind=kind_phys),dimension(its:ite):: & + regime_hv,hfx_hv,qfx_hv,qsfc_hv,mol_hv,rmol_hv,gz1oz0_hv,wspd_hv, & + br_hv,psim_hv,psih_hv,fm_hv,fh_hv,znt_hv,zol_hv,ust_hv,cpm_hv, & + chs2_hv,cqs2_hv,chs_hv,flhc_hv,flqc_hv,qgh_hv + real(kind=kind_phys),dimension(its:ite):: & + ustm_hv + +!----------------------------------------------------------------------------------------------------------------- + + l_isfflx = .false. + l_shalwater_z0 = .false. + l_scm_force_flux = .false. + if(isfflx .eq. 1) l_isfflx = .true. + if(shalwater_z0 .eq. 1) l_shalwater_z0 = .true. + if(scm_force_flux .eq. 1) l_scm_force_flux = .true. + + do j = jts,jte + + do i = its,ite + !input arguments: + dx_hv(i) = dx(i,j) + mavail_hv(i) = mavail(i,j) + pblh_hv(i) = pblh(i,j) + psfc_hv(i) = psfc(i,j) + tsk_hv(i) = tsk(i,j) + xland_hv(i) = xland(i,j) + lakemask_hv(i) = lakemask(i,j) + water_depth_hv(i) = water_depth(i,j) + + do k = kts,kte + dz_hv(i,k) = dz8w(i,k,j) + u_hv(i,k) = u3d(i,k,j) + v_hv(i,k) = v3d(i,k,j) + qv_hv(i,k) = qv3d(i,k,j) + p_hv(i,k) = p3d(i,k,j) + t_hv(i,k) = t3d(i,k,j) + enddo + + !inout arguments: + regime_hv(i) = regime(i,j) + hfx_hv(i) = hfx(i,j) + qfx_hv(i) = qfx(i,j) + qsfc_hv(i) = qsfc(i,j) + mol_hv(i) = mol(i,j) + rmol_hv(i) = rmol(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) + fm_hv(i) = fm(i,j) + fh_hv(i) = fh(i,j) + znt_hv(i) = znt(i,j) + zol_hv(i) = zol(i,j) + ust_hv(i) = ust(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) + flhc_hv(i) = flhc(i,j) + flqc_hv(i) = flqc(i,j) + qgh_hv(i) = qgh(i,j) + enddo + + if(present(ustm)) then + do i = its,ite + ustm_hv(i) = ustm(i,j) + enddo + endif + + call sf_sfclayrev_pre_run(dz2d=dz_hv,u2d=u_hv,v2d=v_hv,qv2d=qv_hv,p2d=p_hv,t2d=t_hv, & + dz1d=dz1d,u1d=u1d,v1d=v1d,qv1d=qv1d,p1d=p1d,t1d=t1d, & + its=its,ite=ite,kts=kts,kte=kte,errmsg=errmsg,errflg=errflg) + + call sf_sfclayrev_run(ux=u1d,vx=v1d,t1d=t1d,qv1d=qv1d,p1d=p1d,dz8w1d=dz1d, & + cp=cp,g=g,rovcp=rovcp,r=r,xlv=xlv,psfcpa=psfc_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,fm=fm_hv,fh=fh_hv,xland=xland_hv,lakemask=lakemask_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,qgh=qgh_hv,qsfc=qsfc_hv,lh=lh_hv, & + gz1oz0=gz1oz0_hv,wspd=wspd_hv,br=br_hv,isfflx=l_isfflx,dx=dx_hv, & + svp1=svp1,svp2=svp2,svp3=svp3,svpt0=svpt0,ep1=ep1,ep2=ep2,karman=karman, & + p1000mb=p1000mb,shalwater_z0=l_shalwater_z0,water_depth=water_depth_hv, & + isftcflx=isftcflx,iz0tlnd=iz0tlnd,scm_force_flux=l_scm_force_flux, & + ustm=ustm_hv,ck=ck_hv,cka=cka_hv,cd=cd_hv,cda=cda_hv, & + its=its,ite=ite,errmsg=errmsg,errflg=errflg & + ) + + do i = its,ite + !output arguments: + lh(i,j) = lh_hv(i) + 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) + + !inout arguments: + regime(i,j) = regime_hv(i) + hfx(i,j) = hfx_hv(i) + qfx(i,j) = qfx_hv(i) + qsfc(i,j) = qsfc_hv(i) + mol(i,j) = mol_hv(i) + rmol(i,j) = rmol_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) + fm(i,j) = fm_hv(i) + fh(i,j) = fh_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) + flhc(i,j) = flhc_hv(i) + flqc(i,j) = flqc_hv(i) + qgh(i,j) = qgh_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 + + !optional inout arguments: + if(present(ustm)) then + do i = its,ite + ustm(i,j) = ustm_hv(i) + enddo + endif + + enddo + + end subroutine sfclayrev + +!================================================================================================================= + end module module_sf_sfclayrev +!================================================================================================================= diff --git a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F index d2ac6a0b48..82d7ef5b02 100644 --- a/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F +++ b/src/core_atmosphere/physics/physics_wrf/module_sf_urban.F @@ -1,10 +1,15 @@ MODULE module_sf_urban -#ifdef mpas -use mpas_atmphys_utilities, only: physics_error_fatal -#define FATAL_ERROR(M) call physics_error_fatal( M ) +!reference: WRF-v4.5.1 +!Laura D. Fowler (laura@ucar.edu)/2023-04-21. +#if defined(mpas) +use mpas_atmphys_utilities, only: physics_message,physics_error_fatal +#define FATAL_ERROR(M) call physics_error_fatal(M) +#define WRITE_MESSAGE(M) call physics_message(M) #else -#define FATAL_ERROR(M) write(0,*) M ; stop +use module_wrf_error +#define FATAL_ERROR(M) call wrf_error_fatal(M) +#define WRITE_MESSAGE(M) call wrf_message(M) #endif !=============================================================================== @@ -26,12 +31,15 @@ MODULE module_sf_urban REAL, ALLOCATABLE, DIMENSION(:) :: RW_TBL REAL, ALLOCATABLE, DIMENSION(:) :: HGT_TBL REAL, ALLOCATABLE, DIMENSION(:) :: AH_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: ALH_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETR_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETB_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETG_TBL REAL, ALLOCATABLE, DIMENSION(:) :: FRC_URB_TBL REAL, ALLOCATABLE, DIMENSION(:) :: COP_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: BLDAC_FRC_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: COOLED_FRC_TBL REAL, ALLOCATABLE, DIMENSION(:) :: PWIN_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETA_TBL INTEGER, ALLOCATABLE, DIMENSION(:) :: SW_COND_TBL @@ -42,6 +50,11 @@ MODULE module_sf_urban REAL, ALLOCATABLE, DIMENSION(:) :: TARGHUM_TBL REAL, ALLOCATABLE, DIMENSION(:) :: GAPHUM_TBL REAL, ALLOCATABLE, DIMENSION(:) :: PERFLO_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: PV_FRAC_ROOF_TBL !GRZ + REAL, ALLOCATABLE, DIMENSION(:) :: GR_FRAC_ROOF_TBL !GRZ + INTEGER :: GR_FLAG_TBL !GRZ + INTEGER :: GR_TYPE_TBL !GRZ + REAL, DIMENSION(1:24) :: IRHO_TBL REAL, ALLOCATABLE, DIMENSION(:) :: HSESF_TBL REAL, ALLOCATABLE, DIMENSION(:) :: CAPR_TBL, CAPB_TBL, CAPG_TBL @@ -74,12 +87,28 @@ MODULE module_sf_urban REAL, DIMENSION(1:24) :: ahdiuprf ! ah diurnal profile, tloc: 1-24 REAL, DIMENSION(1:24) :: hsequip_tbl +!===Yang, 2014/10/08, urban hydrological processes for single layer UCM=== + INTEGER :: IMP_SCHEME, IRI_SCHEME + INTEGER :: alhoption ! anthropogenic latent heat option + INTEGER :: groption ! anthropogenic latent heat option + REAL :: fgr ! green roof fraction + REAL :: oasis ! urban oasis parameter + REAL, DIMENSION(1:4) :: DZGR ! Layer depth of green roof + REAL, DIMENSION(1:4) :: alhseason ! seasonal variation of alh + REAL, DIMENSION(1:48) :: alhdiuprf ! alh diurnal profile, tloc2: 1-48 + REAL, DIMENSION(1:3) :: porimp ! porosity of pavement over impervious surface + REAL, DIMENSION(1:3) :: dengimp ! maximum water-holding depth of pavement + +!===end hydrological processes=== + INTEGER :: allocate_status ! INTEGER :: num_roof_layers ! INTEGER :: num_wall_layers ! INTEGER :: num_road_layers + CHARACTER (LEN=256) , PRIVATE :: mesg + CONTAINS !=============================================================================== @@ -194,6 +223,7 @@ MODULE module_sf_urban ! Following parameter are assigned in run/URBPARM.TBL ! ! AH [ W m{-2} ] : anthropogenic heat ( W m{-2} in the table, converted internally to cal cm{-2} ) +! ALH [ W m{-2} ] : anthropogenic latent heat ( W m{-2} in the table, converted internally to cal cm{-2} ) ! CAPR[ J m{-3} K{-1} ] : heat capacity of roof ( units converted in code to [ cal cm{-3} deg{-1} ] ) ! CAPB[ J m{-3} K{-1} ] : heat capacity of building wall ( units converted in code to [ cal cm{-3} deg{-1} ] ) ! CAPG[ J m{-3} K{-1} ] : heat capacity of road ( units converted in code to [ cal cm{-3} deg{-1} ] ) @@ -227,7 +257,11 @@ MODULE module_sf_urban ! [1: M-O Similarity Theory, 2: Empirical Form (recommend)] ! TS_SCHEME [integer 1 or 2] : Scheme for computing surface temperature (for roof, wall, and road) ! [1: 4-layer model, 2: Force-Restore method] -! +! IMP_SCHEME[integer 1 or 2] : Evaporation scheme for impervious surfaces (roof, wall, and road) +! [1: Hypothesized evaporation during large rainfall events +! [2: Water-holding scheme over impervious surface +! IRI_SCHEME[integer 0 or 1] : Scheme for urban irrigation +! [0: No irrigation, 1: Summertime (May-Sep) irrigation everyday at 9pm] !for BEP ! numdir [ - ] : Number of street directions defined for a particular urban category ! street_direction [ deg ] : Direction of streets for a particular urban category and a particular street direction @@ -256,6 +290,7 @@ MODULE module_sf_urban ! Kusaka et al. (2001) Bound.-Layer Meteor., vol.101, p329-358 ! ! History: +! 2014/10, modified by Jiachuan Yang (ASU) ! 2006/06 modified by H. Kusaka (Univ. Tsukuba), M. Tewari ! 2005/10/26, modified by Fei Chen, Mukul Tewari ! 2003/07/21 WRF , modified by H. Kusaka of CRIEPI (NCAR/MMM) @@ -281,8 +316,10 @@ SUBROUTINE urban(LSOLAR, & ! L SW,ALB,LW,G,RN,PSIM,PSIH, & ! O GZ1OZ0, & ! O CMR_URB,CHR_URB,CMC_URB,CHC_URB, & ! I/O - U10,V10,TH2,Q2,UST & ! O - ) + U10,V10,TH2,Q2,UST,mh_urb,stdh_urb,lf_urb, & ! O + lp_urb,hgt_urb,frc_urb,lb_urb,zo_check, & ! O + CMCR,TGR,TGRL,SMR,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR,DRELB,DRELG,FLXHUMR,FLXHUMB,FLXHUMG) IMPLICIT NONE @@ -325,7 +362,7 @@ SUBROUTINE urban(LSOLAR, & ! L INTEGER, INTENT(IN) :: UTYPE ! urban type [1=Commercial/Industrial, 2=High-intensity residential, ! 3=low-intensity residential] - + INTEGER, INTENT(IN) :: jmonth! current month REAL, INTENT(IN) :: TA ! potential temp at 1st atmospheric level [K] REAL, INTENT(IN) :: QA ! mixing ratio at 1st atmospheric level [kg/kg] REAL, INTENT(IN) :: UA ! wind speed at 1st atmospheric level [m/s] @@ -342,7 +379,6 @@ SUBROUTINE urban(LSOLAR, & ! L REAL, INTENT(IN) :: XLAT ! latitude [deg] REAL, INTENT(IN) :: DELT ! time step [s] - REAL, INTENT(IN) :: ZNT ! roughness length [m] REAL, INTENT(IN) :: CHS,CHS2 ! CH*U at za and 2 m [m/s] REAL, INTENT(INOUT) :: SSGD ! downward direct short wave radiation [W/m/m] @@ -351,6 +387,18 @@ SUBROUTINE urban(LSOLAR, & ! L REAL, INTENT(INOUT) :: CHR_URB REAL, INTENT(INOUT) :: CMC_URB REAL, INTENT(INOUT) :: CHC_URB + REAL, INTENT(INOUT) :: ZNT ! roughness length [m] ! modified by danli +!------------------------------------------------------------------------------- +! I: NUDAPT Input Parameters +!------------------------------------------------------------------------------- + REAL, INTENT(INOUT) :: mh_urb ! mean building height [m] + REAL, INTENT(INOUT) :: stdh_urb ! standard deviation of building height [m] + REAL, INTENT(INOUT) :: hgt_urb ! area weighted mean building height [m] + REAL, INTENT(INOUT) :: lp_urb ! plan area fraction [-] + REAL, INTENT(INOUT) :: frc_urb ! urban fraction [-] + REAL, INTENT(INOUT) :: lb_urb ! building surface to plan area ratio [-] + REAL, INTENT(INOUT), DIMENSION(4) :: lf_urb ! frontal area index [-] + REAL, INTENT(INOUT) :: zo_check ! check for printing ZOC !------------------------------------------------------------------------------- ! O: output variables from Urban to LSM @@ -402,11 +450,30 @@ SUBROUTINE urban(LSOLAR, & ! L REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: TBL REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: TGL +!===Yang,2014/10/08, urban hydrological variables for single layer UCM=== +! FLXHUMR: evaporation over roof [m/s]; FLXHUMRP: at previous time step [m/s] +! FLXHUMB: evaporation over wall [m/s]; FLXHUMBP: at previous time step [m/s] +! FLXHUMG: evaporation over road [m/s]; FLXHUMGP: at previous time step [m/s] + +! DRELR: water retention depth on roof [m]; DRELRP: at previous time stp [m] +! DRELB: water retention depth on wall [m]; DRELBP: at previous time stp [m] +! DRELG: water retention depth on road [m]; DRELGP: at previous time stp [m] + +! TGR: green roof surface temperature [K]; TGRP: at previous time step [K] +! CMCR: Canopy intercepted water on green roof; CMCRP: at previous time step +! SMR: soil moisture at each layer on roof [-]; SMRP: at previous time step +! TGRL:layer temperature on green roof [K] + + REAL, INTENT(INOUT):: FLXHUMR,FLXHUMB,FLXHUMG,DRELR,DRELB,DRELG + REAL, INTENT(INOUT):: TGR,CMCR,CHGR_URB,CMGR_URB + REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: SMR + REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: TGRL + !------------------------------------------------------------------------------- ! L: Local variables from read_param !------------------------------------------------------------------------------- - REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, AH + REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, AH, ALH REAL :: SIGMA_ZED REAL :: CAPR, CAPB, CAPG, AKSR, AKSB, AKSG, ALBR, ALBB, ALBG REAL :: EPSR, EPSB, EPSG, Z0R, Z0B, Z0G, Z0HB, Z0HG @@ -443,12 +510,12 @@ SUBROUTINE urban(LSOLAR, & ! L REAL :: W, VFGS, VFGW, VFWG, VFWS, VFWW REAL :: HOUI1, HOUI2, HOUI3, HOUI4, HOUI5, HOUI6, HOUI7, HOUI8 REAL :: SLX, SLX1, SLX2, SLX3, SLX4, SLX5, SLX6, SLX7, SLX8 - REAL :: FLXTHR, FLXTHB, FLXTHG, FLXHUMR, FLXHUMB, FLXHUMG + REAL :: FLXTHR, FLXTHB, FLXTHG REAL :: SR, SB, SG, RR, RB, RG REAL :: SR1, SR2, SB1, SB2, SG1, SG2, RR1, RR2, RB1, RB2, RG1, RG2 REAL :: HR, HB, HG, ELER, ELEB, ELEG, G0R, G0B, G0G REAL :: ALPHAC, ALPHAR, ALPHAB, ALPHAG - REAL :: CHC, CHR, CHB, CHG, CDC, CDR, CDB, CDG + REAL :: CHC, CHR, CHB, CHG, CDC, CDR, CDB, CDG, CDGR REAL :: C1R, C1B, C1G, TE, TC1, TC2, QC1, QC2, QS0R, QS0B, QS0G,RHO,ES REAL :: DESDT @@ -481,8 +548,55 @@ SUBROUTINE urban(LSOLAR, & ! L REAL :: TRP, TBP, TGP, TCP, QCP, TST, QST - INTEGER :: iteration, K - INTEGER :: tloc + REAL :: WDR,HGT2,BW,DHGT + REAL, parameter :: VonK = 0.4 + REAL :: lambda_f,alpha_macd,beta_macd,lambda_fr + + INTEGER :: iteration, K, NUDAPT + INTEGER :: tloc, tloc2, Kalh + +!===Yang,2014/10/08, urban hydrological variables for single layer UCM=== + REAL :: FLXHUMRP, FLXHUMBP, FLXHUMGP + REAL :: DRELRP, DRELBP, DRELGP + REAL :: TGRP, CMCRP + REAL, DIMENSION(1:num_roof_layers) :: ZSOILR, ETR, SMRP +!===Define parameters for green roof=== + INTEGER :: KZ + REAL :: RUNOFF1, RUNOFF2, RUNOFF3 + REAL :: SGR, SGR1, T1VGR, CHGR, ALPHAGR + REAL :: FLXTHGR, FLXHUMGR, HGR, ELEGR, G0GR + REAL :: QS0GR, EPGR, EDIR, ETTR, FV, DTGR, DRIP +! REAL :: DQS0GRDTGR, ETR, ECR,RAIN1, RAINDR, DEW, ETAR, BETGR + REAL :: DQS0GRDTGR, ECR,RAIN1, RAINDR, DEW, ETAR, BETGR +! REAL :: DF1, RGR, RGRR, RCH, RR1, RR2, YY, ZZ1, SSOILR + REAL :: DF1, RGR, RGRR, RCH, YY, ZZ1, SSOILR + REAL :: DRRDTGR, DHRDTGR, DELERDTGR, DG0RDTGR, DFDVT + real,parameter :: SHDFAC = 0.80 ! Vegetated area fraction of green roof vegetation + real,parameter :: ALBV = 0.20 ! green roof albedo + real,parameter :: EPSV = 0.93 ! green roof emissivity + real,parameter :: LAI = 1.50 ! leaf area index on green roof + real,parameter :: CMCMAX = 0.5E-3 ! Maximum canopy interception capacity + real,parameter :: SMCREF = 0.329 ! Reference soil moisture + real,parameter :: SMCDRY = 0.066 ! Residual soil moisture + real,parameter :: SMCWLT = 0.084 ! Wilting point + real,parameter :: SMCMAX = 0.439 ! Saturated soil moisture + real,parameter :: RSMAX = 5000 ! Maximum stomatal resistance + real,parameter :: RSMIN = 100 ! Minimum stomatal resistance + real,parameter :: RGL = 100 ! Radiation limit where photosynthesis begins + real,parameter :: CFACTR = 0.5 ! Parameter used in the canopy inteception calculation + real,parameter :: DWSAT = 0.143E-4 ! Saturated soil conductivity + real,parameter :: DKSAT = 3.38E-6 ! Saturated soil diffusivity + real,parameter :: BEXP = 5.25 ! B parameter in soil hydraulic calculation + real,parameter :: FXEXP = 2.0 ! Parameter for computing direct soil evaporation + real,parameter :: ZBOT = -2.0 + real,parameter :: QUARTZ = 0.40 + real,parameter :: CSOIL = 2.0E+6 + real,parameter :: HS = 36 + integer,parameter :: NROOT = 2 ! Root depth layer of green roof + integer,parameter :: NGR = 4 ! Layer of green roof + integer,parameter :: IMPR = 1 + integer,parameter :: IMPB = 2 + integer,parameter :: IMPG = 3 !------------------------------------------------------------------------------- ! Set parameters @@ -491,8 +605,15 @@ SUBROUTINE urban(LSOLAR, & ! L ! Miao, 2007/01/17, cal. ah if(ahoption==1) then tloc=mod(int(OMG/PI*180./15.+12.+0.5 ),24) + if(tloc.lt.0) tloc=tloc+24 if(tloc==0) tloc=24 endif +! Yang, 2014/10/08, cal. alh + if(alhoption==1) then + tloc2=mod(int((OMG/PI*180./15.+12.)*2.+0.5 ),48) + if(tloc2.lt.0) tloc2=tloc2+48 + if(tloc2==0) tloc2=48 + endif CALL read_param(UTYPE,ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT, & AH,CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB, & @@ -504,11 +625,167 @@ SUBROUTINE urban(LSOLAR, & ! L HPERCENT_BIN, & !end BEP BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & - AKANDA_URBAN) + AKANDA_URBAN,ALH) + +! Glotfelty, 2012/07/05, NUDAPT Modification + + if(mh_urb.gt.0.0)THEN + !write(mesg,*) 'Mean Height NUDAPT',mh_urb + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'Mean Height Table',ZR + !WRITE_MESSAGE(mesg) + if(zo_check.eq.1)THEN + write(mesg,*) 'Mean Height NUDAPT',mh_urb + WRITE_MESSAGE(mesg) + write(mesg,*) 'Mean Height Table',ZR + WRITE_MESSAGE(mesg) + write(mesg,*) 'Roughness Length Table',Z0C + WRITE_MESSAGE(mesg) + write(mesg,*) 'Roof Roughness Length Table',Z0R + WRITE_MESSAGE(mesg) + write(mesg,*) 'Sky View Factor Table',SVF + WRITE_MESSAGE(mesg) + write(mesg,*) 'Normalized Height Table',HGT + WRITE_MESSAGE(mesg) + write(mesg,*) 'Plan Area Fraction', lp_urb + WRITE_MESSAGE(mesg) + write(mesg,*) 'Plan Area Fraction table', R + WRITE_MESSAGE(mesg) + end if + !write(mesg,*) 'Area Weighted Mean Height',hgt_urb + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'Plan Area Fraction', lp_urb + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'STD Height', stdh_urb + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'Frontal Area Index',lf_urb + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'Urban Fraction',frc_urb + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'Building Surf Ratio',lb_urb + !WRITE_MESSAGE(mesg) + + !Calculate Building Width and Street Width Based on BEP formulation + if(lb_urb.gt.lp_urb)THEN + BW=2.*hgt_urb*lp_urb/(lb_urb-lp_urb) + SW=2.*hgt_urb*lp_urb*((frc_urb/lp_urb)-1.)/(lb_urb-lp_urb) + !write(mesg,*) 'Building Width',BW + !WRITE_MESSAGE(mesg) + !write(mesg,*) 'Street Width',SW + !WRITE_MESSAGE(mesg) + elseif (SW.lt.0.0.or.BW.lt.0.0)then + BW=BUILDING_WIDTH(1) + SW=STREET_WIDTH(1) + else + BW=BUILDING_WIDTH(1) + SW=STREET_WIDTH(1) + end if + + !Assign NUDAPT Parameters + ZR = mh_urb + R = lp_urb + RW = 1.0-R + HGT = mh_urb/(BW+SW) + SIGMA_ZED = stdh_urb + + !Calculate Wind Direction and Assign Appropriae lf_urb + WDR = (180.0/PI)*ATAN2(U10,V10) + + IF(WDR.ge.0.0.and.WDR.lt.22.5)THEN + lambda_f = lf_urb(1) + ELSEIF(WDR.ge.-22.5.and.WDR.lt.0.0)THEN + lambda_f = lf_urb(1) + ELSEIF(WDR.gt.157.5.and.WDR.le.180.0)THEN + lambda_f = lf_urb(1) + ELSEIF(WDR.lt.-157.5)THEN + lambda_f = lf_urb(1) + ELSEIF(WDR.gt.22.5.and.WDR.le.67.5)THEN + lambda_f = lf_urb(2) + ELSEIF(WDR.ge.-157.5.and.WDR.lt.-112.5)THEN + lambda_f = lf_urb(2) + ELSEIF(WDR.gt.67.5.and.WDR.le.112.5)THEN + lambda_f = lf_urb(3) + ELSEIF(WDR.ge.-112.5.and.WDR.lt.-67.5)THEN + lambda_f = lf_urb(3) + ELSEIF(WDR.gt.112.5.and.WDR.le.157.5)THEN + lambda_f = lf_urb(4) + ELSEIF(WDR.ge.-67.5.and.WDR.lt.-22.5)THEN + lambda_f = lf_urb(4) + ELSE + lambda_f = lf_urb(1) + ENDIF + + !Calculate the following urban canyon geometry parameters following Macdonald's (1998) formulations + Cd = 1.2 + alpha_macd = 4.43 + beta_macd = 1.0 + + + ZDC = ZR * ( 1.0 + ( alpha_macd ** ( -R ) ) * ( R - 1.0 ) ) + + Z0C = ZR * ( 1.0 - ZDC/ZR ) * & + exp (-(0.5 * beta_macd * Cd / (VonK**2) * ( 1.0-ZDC/ZR) * lambda_f )**(-0.5)) + + if(zo_check.eq.1)THEN + write(mesg,*) 'Roughness Length NUDAPT',Z0C + WRITE_MESSAGE(mesg) + end if + + lambda_fr = stdh_urb/(SW + BW) + + Z0R = ZR * ( 1.0 - ZDC/ZR) & + * exp ( -(0.5 * beta_macd * Cd / (VonK**2) & + * ( 1.0-ZDC/ZR) * lambda_fr )**(-0.5)) + + + + Z0HC = 0.1 * Z0C + + ! Calculate Sky View Factor + + DHGT=HGT/100. + HGT2=0. + VFWS=0. + HGT2=HGT-DHGT/2. + do NUDAPT=1,99 + HGT2=HGT2-DHGT + VFWS=VFWS+0.25*(1.-HGT2/SQRT(HGT2**2.+RW**2.)) + end do + + VFWS=VFWS/99. + VFWS=VFWS*2. + + VFGS=1.-2.*VFWS*HGT/RW + SVF=VFGS + + if(zo_check.eq.1)THEN + write(mesg,*) 'Roof Roughness Length NUDAPT',Z0R + WRITE_MESSAGE(mesg) + write(mesg,*) 'Sky View Factor NUDAPT',SVF + WRITE_MESSAGE(mesg) + write(mesg,*) 'normalized Height NUDAPT', HGT + WRITE_MESSAGE(mesg) + end if + + + endif + + !End NUDAPT Modification + ! Miao, 2007/01/17, cal. ah if(ahoption==1) AH=AH*ahdiuprf(tloc) +! Yang, 2014/10/08, cal. alh + Kalh=0 + if(alhoption==1) THEN + if(jmonth==3 .or. jmonth==4 .or. jmonth==5) Kalh=1 + if(jmonth==6 .or. jmonth==7 .or. jmonth==8) Kalh=2 + if(jmonth==9 .or. jmonth==10.or. jmonth==11)Kalh=3 + if(jmonth==12.or. jmonth==1 .or. jmonth==2) Kalh=4 + endif + if(alhoption==1) ALH = ALH*alhdiuprf(tloc2)*alhseason(Kalh) + IF( ZDC+Z0C+2. >= ZA) THEN FATAL_ERROR("ZDC + Z0C + 2m is larger than the 1st WRF level - Stop in subroutine urban - change ZDC and Z0C" ) END IF @@ -544,6 +821,29 @@ SUBROUTINE urban(LSOLAR, & ! L TCP=TC QCP=QC +!===Yang,2014/10/08, urban hydrological variables for single layer UCM=== + FLXHUMRP = FLXHUMR + FLXHUMBP = FLXHUMB + FLXHUMGP = FLXHUMG + DRELRP = DRELR + DRELBP = DRELB + DRELGP = DRELG + TGRP = TGR + CMCRP = CMCR + SMRP = SMR + +!===Yang,2014/10/08, urban irrigation, May-Sep, 9-10pm + IF(IRI_SCHEME==1) THEN + IF (tloc==21 .or. tloc==22) THEN + IF(jmonth==5 .or. jmonth==6 .or. jmonth ==7 .or. & + jmonth==8 .or. jmonth==9 ) THEN + DO KZ = 1,2 + SMRP(KZ)= SMCREF + END DO + ENDIF + ENDIF + ENDIF + TAV=TA*(1.+0.61*QA) PS=RHOO*287.*TAV/100. ![hPa] @@ -576,6 +876,7 @@ SUBROUTINE urban(LSOLAR, & ! L IF(.NOT.SHADOW) THEN ! no shadow effects model SR1=SX*(1.-ALBR) + SGR1=SX*(1.-ALBV) SG1=SX*VFGS*(1.-ALBG) SB1=SX*VFWS*(1.-ALBB) SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG) @@ -621,6 +922,7 @@ SUBROUTINE urban(LSOLAR, & ! L SLX=(SLX1+SLX2+SLX3+SLX4+SLX5+SLX6+SLX7+SLX8)/8. SR1=SD*(1.-ALBR)+SQ*(1.-ALBR) + SGR1=SD*(1.-ALBV)+SQ*(1.-ALBV) SG1=SD*(RW-SLX)/RW*(1.-ALBG)+SQ*VFGS*(1.-ALBG) SB1=SD*SLX/W*(1.-ALBB)+SQ*VFWS*(1.-ALBB) SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG) @@ -629,15 +931,21 @@ SUBROUTINE urban(LSOLAR, & ! L END IF SR=SR1 + SGR=SGR1 SG=SG1+SG2 SB=SB1+SB2 + IF (GROPTION ==1) THEN + SNET=R*FGR*SGR+R*(1.-FGR)*SR+W*SB+RW*SG + ELSE SNET=R*SR+W*SB+RW*SG + ENDIF ELSE SR=0. SG=0. + SGR=0. SB=0. SNET=0. @@ -667,7 +975,30 @@ SUBROUTINE urban(LSOLAR, & ! L ALPHAR = RHO*CP*CHR_URB CHR=ALPHAR/RHO/CP/UA - IF(RAIN > 1.) BETR=0.7 +! Yang, 03/12/2014 -- LH for impervious roof surface + RAIN1 = RAIN * 0.001 /3600 ! CONVERT FROM mm/hr to m/s + IF (IMP_SCHEME==1) then + IF (RAIN > 1.) BETR=0.7 + ENDIF + + IF (IMP_SCHEME==2) then + IF (FLXHUMRP <= 0.) FLXHUMRP = 0. +! Compute water retention depth from previous time step + DrelR = DrelRP+(RAIN1-FLXHUMRP)*DELT/porimp(IMPR) + IF (RAIN > 0. .AND. DrelR < DrelRP) DrelR = DrelRP + + IF (DrelR <= 0.) then + DrelR = 0.0 + BETR = 0.0 + ELSEIf (DrelR <= dengimp(IMPR)) then + BETR = DrelR/dengimp(IMPR)*porimp(IMPR) + ELSE + DrelR = dengimp(IMPR) + BETR = porimp(IMPR) + ENDIF + + IF ( BETR < 1.E-5 ) BETR = 0.0 + ENDIF IF (TS_SCHEME == 1) THEN @@ -740,6 +1071,113 @@ SUBROUTINE urban(LSOLAR, & ! L FLXTHR=HR/RHO/CP/100. FLXHUMR=ELER/RHO/EL/100. +!------------------------------------------------------------------------------- +! Green Roof +! Must use multiple layers scheme (TS_SCHEME=1) +!------------------------------------------------------------------------------- + IF (GROPTION == 1) THEN + T1VGR = TGRP* (1.0+ 0.61 * QA) + RLMO_URB=0.0 + CALL SFCDIF_URB (ZA,Z0R,T1VGR,TH2V,UA,AKANDA_URBAN,CMGR_URB,CHGR_URB,RLMO_URB,CDGR) + ALPHAGR = RHO*CP*CHGR_URB + CHGR=ALPHAGR/RHO/CP/UA + RUNOFF1 = 0.0 + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + + KZ = 1 + ZSOILR (KZ) = - DZGR (KZ) + DO KZ = 2,NGR + ZSOILR (KZ) = - DZGR(KZ) + ZSOILR (KZ -1) + END DO + + DO ITERATION=1,100 + KZ=1 + ES=6.11*EXP( (2.5*10.**6./461.51)*(TGRP-273.15)/(273.15*TGRP) ) + DESDT=(2.5*10.**6./461.51)*ES/(TGRP**2.) + QS0GR=0.622*ES/(PS-0.378*ES) + DQS0GRDTGR = DESDT*0.622*PS/((PS-0.378*ES)**2.) + EPGR=RHOO*CHGR*UA*(QS0GR-QA) ! Potential evaporation [kg/m2/s] + + IF (EPGR > 0.0) THEN + ! Direct evaporation from soil on green roof + CALL DIREVAP (EDIR,EPGR,SMRP(KZ),SHDFAC,SMCMAX,SMCDRY,FXEXP) + ! Evapotranspiration and canopy intercepted evaporation + CALL TRANSP (ETTR,ETR,ECR,SHDFAC,EPGR,CMCRP,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,SX, & + TGRP,TA,QA,SMRP,SMCWLT,SMCREF,CPP,PS,CHGR,EPSV,DELT,NROOT,NGR,DZGR, & + ZSOILR,HS) + ! Update moisture in soil layers + CALL SMFLX (SMRP,SMR,NGR,CMCRP,CMCR,DELT,RAIN,ZSOILR,SMCMAX,BEXP,SMCWLT,DKSAT,& + DWSAT,SHDFAC,CMCMAX,RUNOFF1,RUNOFF2,RUNOFF3,EDIR,ECR,ETR,DRIP) + else + DEW = - EPGR + RAINDR = RAIN + DEW * 3600. + EDIR=0.0 + ECR =0.0 + ETTR=0.0 + CALL SMFLX (SMRP,SMR,NGR,CMCRP,CMCR,DELT,RAINDR,ZSOILR,SMCMAX,BEXP,SMCWLT,DKSAT,& + DWSAT,SHDFAC,CMCMAX,RUNOFF1,RUNOFF2,RUNOFF3,EDIR,ECR,ETR,DRIP) + END IF +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1. +! ---------------------------------------------------------------------- + EDIR = EDIR * 1000.0 + ETTR = ETTR * 1000.0 + ECR = ECR * 1000.0 + ETAR = EDIR + ETTR + ECR + IF (ETAR < 1.E-20) ETAR = 0.0 + + IF ( EPGR <= 0.0 ) THEN + BETGR = 0.0 + ELSE + BETGR = ETAR / EPGR + END IF + ELEGR= ETAR* RHO * EL /RHOO * 100 + + CALL TDFCND (DF1,SMR(KZ), QUARTZ, SMCMAX ) + DF1 = DF1 * EXP(-2.0 * SHDFAC) + RGR = EPSV*(RX-SIG*(TGRP**4.)/60.) + RGRR= (SGR+RGR) * 697.7 * 60. + RCH = RHOO*CPP*CHGR + RR1 = EPSV*(TA**4) * 6.48E-8 / (PS* CHGR) + 1.0 + IF (RAIN > 0.0) then + RR2 = RR1 + RAIN / 3600 * 4.218E+3 / RCH + else + RR2 = RR1 + end if + YY = TA + (RGRR / RCH - BETGR * EPGR * ELL/ RCH) / RR2 + ZZ1 = DF1 / (-0.5 * ZSOILR (KZ) * RCH * RR2 ) + 1.0 + + + HGR=RHO*CP*CHGR*UA*(TGRP-TA)*100. + RUNOFF3 = RUNOFF3/ DELT + RUNOFF2 = RUNOFF2+ RUNOFF3 + G0GR = DF1*(TGRP-TGRL(1))/(DZGR(1)/2.)/697.7/60 + + FV = SGR + RGR - HGR - ELEGR - G0GR + DRRDTGR = (-4.*EPSV*SIG*TGRP**3.)/60. + DHRDTGR = RHO*CP*CHGR*UA*100. + DELERDTGR = RHO*EL*CHGR*UA*BETGR*DQS0GRDTGR*100. + DG0RDTGR = 2.*DF1/ DZGR(KZ) * ( 1.0 / 4.1868 ) * 1.E-4 + DFDVT = DRRDTGR - DHRDTGR - DELERDTGR - DG0RDTGR + DTGR = FV/DFDVT/ 6 + TGR = TGRP - DTGR + TGRP = TGR + + IF( ABS(FV) < 0.0001 .AND. ABS(DTGR) < 0.001 ) then + EXIT + ENDIF + END DO + ! Update temperature in soil layer + CALL SHFLX (SSOILR,TGRL,SMR,SMCMAX,NGR,TGRP,DELT,YY,ZZ1,ZSOILR, & + TRLEND,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) + FLXTHGR=HGR/RHO/CP/100. + FLXHUMGR=ELEGR/RHO/EL/100. +ELSE + FLXTHGR=0. + FLXHUMGR=0. +ENDIF + !------------------------------------------------------------------------------- ! Wall and Road !------------------------------------------------------------------------------- @@ -784,8 +1222,45 @@ SUBROUTINE urban(LSOLAR, & ! L CHB=ALPHAB/RHO/CP/UC CHG=ALPHAG/RHO/CP/UC +!Yang 10/10/2013 -- LH from impervious wall and ground + IF (IMP_SCHEME==1) then BETB=0.0 IF(RAIN > 1.) BETG=0.7 + ENDIF + + IF (IMP_SCHEME==2) then + IF (FLXHUMBP <= 0.) FLXHUMBP = 0. + IF (FLXHUMGP <= 0.) FLXHUMGP = 0. +! Compute water retention from previous time step for wall and ground + DrelB = DrelBP+(RAIN1-FLXHUMBP)*DELT/porimp(IMPB) + IF (RAIN > 0. .AND. DrelB < DrelBP) DrelB = DrelBP + DrelG = DrelGP+(RAIN1-FLXHUMGP)*DELT/porimp(IMPG) + IF (RAIN > 0. .AND. DrelG < DrelGP) DrelG = DrelGP + + IF (DrelB <= 0.) then + DrelB = 0.0 + BETB = 0.0 + ELSEIf (DrelB <= dengimp(IMPB)) then + BETB = DrelB/dengimp(IMPB)*porimp(IMPB) + ELSE + DrelB = dengimp(IMPB) + BETB = porimp(IMPB) + ENDIF + + IF (DrelG <= 0.) then + DrelG = 0.0 + BETG = 0.0 + ELSEIf (DrelG <= dengimp(IMPG)) then + BETG = DrelG/dengimp(IMPG)*porimp(IMPG) + ELSE + DrelG = dengimp(IMPG) + BETG = porimp(IMPG) + ENDIF + + if ( BETG < 1.E-5 ) BETG = 0.0 + if ( BETB < 1.E-5 ) BETB = 0.0 + +ENDIF IF (TS_SCHEME == 1) THEN @@ -986,17 +1461,36 @@ SUBROUTINE urban(LSOLAR, & ! L !------------------------------------------------------------------------------- ! Total Fluxes from Urban Canopy !------------------------------------------------------------------------------- - - FLXUV = ( R*CDR + RW*CDC )*UA*UA -! Miao, 2007/01/17, cal. ah +!===Yang, 2014/10/08, cal. ah. alh. green roof=== + if(groption==1) then + if(ahoption==1) then + FLXTH = ((1.-FGR)*R*FLXTHR + FGR*R*FLXTHGR + W*FLXTHB + RW*FLXTHG)+ AH/RHOO/CPP + else + FLXTH = ((1.-FGR)*R*FLXTHR + FGR*R*FLXTHGR + W*FLXTHB + RW*FLXTHG) + endif + if(alhoption==1) then + FLXHUM = ((1.-FGR)*R*FLXHUMR + FGR*R*FLXHUMGR + W*FLXHUMB + RW*FLXHUMG)+ ALH/RHOO/ELL + else + FLXHUM = ((1.-FGR)*R*FLXHUMR + FGR*R*FLXHUMGR + W*FLXHUMB + RW*FLXHUMG) + endif + FLXUV = ((1.-FGR)*R*CDR + FGR*R*CDGR + RW*CDC )*UA*UA + FLXG = ((1.-FGR)*R*G0R + FGR*R*G0GR+ W*G0B + RW*G0G) + LNET = (1.-FGR) * R * RR + FGR *R* RGR + W * RB + RW * RG + else if(ahoption==1) then FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG ) + AH/RHOO/CPP else FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG ) endif - FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG ) + if(alhoption==1) then + FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG )+ ALH/RHOO/ELL + else + FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG ) + endif + FLXUV = ( R*CDR + RW*CDC )*UA*UA FLXG = ( R*G0R + W*G0B + RW*G0G ) LNET = R*RR + W*RB + RW*RG + endif !---------------------------------------------------------------------------- ! Convert Unit: FLUXES and u* T* q* --> WRF @@ -1023,6 +1517,7 @@ SUBROUTINE urban(LSOLAR, & ! L Z0 = Z0C Z0H = Z0HC Z = ZA - ZDC + ZNT = Z0 ! add by Dan Li XXX = 0.4*9.81*Z*TST/TA/UST/UST @@ -1364,11 +1859,11 @@ SUBROUTINE read_param(UTYPE, & ! in HPERCENT_BIN, & ! out !end BEP BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & ! out - AKANDA_URBAN) ! out + AKANDA_URBAN,ALH) ! out INTEGER, INTENT(IN) :: UTYPE - REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & + REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH,ALH, & CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & SIGMA_ZED, & EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, & @@ -1397,6 +1892,7 @@ SUBROUTINE read_param(UTYPE, & ! in RW= RW_TBL(UTYPE) HGT= HGT_TBL(UTYPE) AH= AH_TBL(UTYPE) + ALH= ALH_TBL(UTYPE) BETR= BETR_TBL(UTYPE) BETB= BETB_TBL(UTYPE) BETG= BETG_TBL(UTYPE) @@ -1454,7 +1950,7 @@ END SUBROUTINE read_param ! !=============================================================================== SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & - sf_urban_physics) + sf_urban_physics,use_wudapt_lcz) ! num_roof_layers,num_wall_layers,num_road_layers) IMPLICIT NONE @@ -1468,6 +1964,7 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZB REAL, DIMENSION(1:num_soil_layers), INTENT(INOUT) :: DZG INTEGER, INTENT(IN) :: SF_URBAN_PHYSICS + INTEGER, INTENT(IN) :: USE_WUDAPT_LCZ !AndreaLCZ INTEGER :: LC, K INTEGER :: IOSTATUS, ALLOCATE_STATUS @@ -1503,8 +2000,10 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & num_road_layers = num_soil_layers - ICATE=0 + ICATE=0 + + if(USE_WUDAPT_LCZ.eq.0)then !AndreaLCZ OPEN (UNIT=11, & FILE='URBPARM.TBL', & ACCESS='SEQUENTIAL', & @@ -1513,9 +2012,24 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & POSITION='REWIND', & IOSTAT=IOSTATUS) - IF (IOSTATUS > 0) THEN - FATAL_ERROR('ERROR OPEN URBPARM.TBL') - ENDIF + IF (IOSTATUS > 0) THEN + FATAL_ERROR('Error opening URBPARM.TBL. Make sure URBPARM.TBL (found in run/) is linked to the running directory.') + ENDIF + + else + OPEN (UNIT=11, & + FILE='URBPARM_LCZ.TBL', & + ACCESS='SEQUENTIAL', & + STATUS='OLD', & + ACTION='READ', & + POSITION='REWIND', & + IOSTAT=IOSTATUS) + + IF (IOSTATUS > 0) THEN + FATAL_ERROR('Error opening URBPARM_LCZ.TBL. Make sure URBPARM_LCZ.TBL (found in run/) is linked to the running directory.') + ENDIF + endif + READLOOP : do read(11,'(A512)', iostat=iostatus) string @@ -1550,6 +2064,8 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if(allocate_status /= 0) FATAL_ERROR('Error allocating HGT_TBL in urban_param_init') ALLOCATE( AH_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating AH_TBL in urban_param_init') + ALLOCATE( ALH_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating ALH_TBL in urban_param_init') ALLOCATE( BETR_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating BETR_TBL in urban_param_init') ALLOCATE( BETB_TBL(ICATE), stat=allocate_status ) @@ -1601,9 +2117,9 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & ALLOCATE( FRC_URB_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating FRC_URB_TBL in urban_param_init') ! ALLOCATE( ROOF_WIDTH(ICATE), stat=allocate_status ) - if(allocate_status /= 0) FATAL_ERROR('Error allocating ROOF_WIDTH in urban_param_init') + ! if(allocate_status /= 0) FATAL_ERROR('Error allocating ROOF_WIDTH in urban_param_init') ! ALLOCATE( ROAD_WIDTH(ICATE), stat=allocate_status ) - if(allocate_status /= 0) FATAL_ERROR('Error allocating ROAD_WIDTH in urban_param_init') + ! if(allocate_status /= 0) FATAL_ERROR('Error allocating ROAD_WIDTH in urban_param_init') !for BEP ALLOCATE( NUMDIR_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating NUMDIR_TBL in urban_param_init') @@ -1621,6 +2137,10 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if(allocate_status /= 0) FATAL_ERROR('Error allocating HPERCENT_BIN_TBL in urban_param_init') ALLOCATE( COP_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating COP_TBL in urban_param_init') + ALLOCATE( BLDAC_FRC_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating BLDAC_FRC_TBL in urban_param_init') + ALLOCATE( COOLED_FRC_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating COOLED_FRC_TBL in urban_param_init') ALLOCATE( PWIN_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating PWIN_TBL in urban_param_init') ALLOCATE( BETA_TBL(ICATE), stat=allocate_status ) @@ -1643,6 +2163,11 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if(allocate_status /= 0) FATAL_ERROR('Error allocating PERFLO_TBL in urban_param_init') ALLOCATE( HSESF_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) FATAL_ERROR('Error allocating HSESF_TBL in urban_param_init') + ALLOCATE( PV_FRAC_ROOF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating PV_FRAC_ROOF_TBL in urban_param_init') + ALLOCATE( GR_FRAC_ROOF_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) FATAL_ERROR('Error allocating GR_FRAC_ROOF_TBL in urban_param_init') + endif numdir_tbl = 0 street_direction_tbl = -1.E36 @@ -1668,6 +2193,8 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) road_width(1:icate) else if (name == "AH") then read(string(indx+1:),*) ah_tbl(1:icate) + else if (name == "ALH") then + read(string(indx+1:),*) alh_tbl(1:icate) else if (name == "FRC_URB") then read(string(indx+1:),*) frc_urb_tbl(1:icate) else if (name == "CAPR") then @@ -1744,6 +2271,28 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) ahoption else if (name == "AHDIUPRF") then read(string(indx+1:),*) ahdiuprf(1:24) + else if (name == "ALHOPTION") then + read(string(indx+1:),*) alhoption + else if (name == "ALHSEASON") then + read(string(indx+1:),*) alhseason(1:4) + else if (name == "ALHDIUPRF") then + read(string(indx+1:),*) alhdiuprf(1:48) + else if (name == "PORIMP") then + read(string(indx+1:),*) porimp(1:3) + else if (name == "DENGIMP") then + read(string(indx+1:),*) dengimp(1:3) + else if (name == "IMP_SCHEME") then + read(string(indx+1:),*) imp_scheme + else if (name == "IRI_SCHEME") then + read(string(indx+1:),*) iri_scheme + else if (name == "OASIS") then + read(string(indx+1:),*) oasis + else if (name == "GROPTION") then + read(string(indx+1:),*) groption + else if (name == "FGR") then + read(string(indx+1:),*) fgr + else if (name == "DZGR") then + read(string(indx+1:),*) dzgr(1:4) !for BEP else if (name == "STREET PARAMETERS") then @@ -1783,6 +2332,10 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) Z0R_tbl(1:icate) else if ( name == "COP") then read(string(indx+1:),*) cop_tbl(1:icate) + else if ( name == "BLDAC_FRC") then + read(string(indx+1:),*) bldac_frc_tbl(1:icate) + else if ( name == "COOLED_FRC") then + read(string(indx+1:),*) cooled_frc_tbl(1:icate) else if ( name == "PWIN") then read(string(indx+1:),*) pwin_tbl(1:icate) else if ( name == "BETA") then @@ -1807,6 +2360,17 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) hsequip_tbl(1:24) else if (name == "HSEQUIP_SCALE_FACTOR") then read(string(indx+1:),*) hsesf_tbl(1:icate) + else if (name == "IRHO") then + read(string(indx+1:),*) IRHO_TBL(1:24) + else if ( name == "PV_FRAC_ROOF") then + read(string(indx+1:),*) pv_frac_roof_tbl(1:icate) + else if ( name == "GR_FRAC_ROOF") then + read(string(indx+1:),*) gr_frac_roof_tbl(1:icate) + else if (name == "GR_FLAG") then + read(string(indx+1:),*) gr_flag_tbl + else if (name == "GR_TYPE") then + read(string(indx+1:),*) gr_type_tbl + !end BEP else FATAL_ERROR('URBPARM.TBL: Unrecognized NAME = "'//trim(name)//'" in Subr URBAN_PARAM_INIT') @@ -1898,14 +2462,26 @@ END SUBROUTINE urban_param_init !=========================================================================== SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, & ! in ims,ime,jms,jme,kms,kme,num_soil_layers, & ! in -! num_roof_layers,num_wall_layers,num_road_layers, & ! in + LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5, & + LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11, & restart,sf_urban_physics, & !in XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & ! inout TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & ! inout TRL_URB3D,TBL_URB3D,TGL_URB3D, & ! inout SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, & ! inout TS_URB2D, & ! inout - num_urban_layers, & ! in + num_urban_ndm, & ! in + urban_map_zrd, & ! in + urban_map_zwd, & ! in + urban_map_gd, & ! in + urban_map_zd, & ! in + urban_map_zdf, & ! in + urban_map_bd, & ! in + urban_map_wd, & ! in + urban_map_gbd, & ! in + urban_map_fbd, & ! in + urban_map_zgrd, & ! in + num_urban_hi, & ! in TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D, & ! inout TLEV_URB3D,QLEV_URB3D, & ! inout TW1LEV_URB3D,TW2LEV_URB3D, & ! inout @@ -1914,16 +2490,39 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SFVENT_URB3D,LFVENT_URB3D, & ! inout SFWIN1_URB3D,SFWIN2_URB3D, & ! inout SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D, & ! inout + EP_PV_URB3D,T_PV_URB3D, & !GRZ + TRV_URB4D,QR_URB4D,QGR_URB3D,TGR_URB3D, & !GRZ + DRAIN_URB4D,DRAINGR_URB3D,SFRV_URB3D, & !GRZ + LFRV_URB3D,DGR_URB3D,DG_URB3D,LFR_URB3D,LFG_URB3D,&!GRZ + SMOIS_URB, & + LP_URB2D,HI_URB2D,LB_URB2D, & ! inout + HGT_URB2D,MH_URB2D,STDH_URB2D, & ! inout + LF_URB2D, & ! inout + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & ! inout + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & ! inout + FLXHUMR_URB2D, FLXHUMB_URB2D, FLXHUMG_URB2D, & ! inout A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & ! inout multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & ! inout multi-layer urban B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP, & ! inout multi-layer urban DL_U_BEP,SF_BEP,VL_BEP, & ! inout multi-layer urban - FRC_URB2D, UTYPE_URB2D) ! inout + FRC_URB2D, UTYPE_URB2D,USE_WUDAPT_LCZ) ! inout IMPLICIT NONE - INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics + INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics,use_wudapt_lcz + INTEGER, INTENT(IN) :: LCZ_1,LCZ_2,LCZ_3,LCZ_4,LCZ_5,LCZ_6,LCZ_7,LCZ_8,LCZ_9,LCZ_10,LCZ_11 INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme,num_soil_layers - INTEGER, INTENT(IN) :: num_urban_layers !multi-layer urban + INTEGER, INTENT(IN) :: num_urban_ndm + INTEGER, INTENT(IN) :: urban_map_zrd + INTEGER, INTENT(IN) :: urban_map_zwd + INTEGER, INTENT(IN) :: urban_map_gd + INTEGER, INTENT(IN) :: urban_map_zd + INTEGER, INTENT(IN) :: urban_map_zdf + INTEGER, INTENT(IN) :: urban_map_bd + INTEGER, INTENT(IN) :: urban_map_wd + INTEGER, INTENT(IN) :: urban_map_gbd + INTEGER, INTENT(IN) :: urban_map_fbd + INTEGER, INTENT(IN) :: urban_map_zgrd + INTEGER, INTENT(IN) :: num_urban_hi !multi-layer urban ! INTEGER, INTENT(IN) :: num_roof_layers, num_wall_layers, num_road_layers REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: TSURFACE0_URB @@ -1942,12 +2541,23 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + ! REAL, DIMENSION(ims:ime, 1:num_roof_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D ! REAL, DIMENSION(ims:ime, 1:num_wall_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D ! REAL, DIMENSION(ims:ime, 1:num_road_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGRL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: SMR_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D @@ -1956,27 +2566,49 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D ! multi-layer UCM variables - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TRB_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW1_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TW2_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TGB_URB4D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: TLEV_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: QLEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW1LEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TW2LEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TGLEV_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: TFLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zrd, jms:jme), INTENT(INOUT) :: TRB_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_zwd, jms:jme), INTENT(INOUT) :: TW1_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_zwd, jms:jme), INTENT(INOUT) :: TW2_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_gd , jms:jme), INTENT(INOUT) :: TGB_URB4D + REAL, DIMENSION(ims:ime, 1:urban_map_bd , jms:jme), INTENT(INOUT) :: TLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_bd , jms:jme), INTENT(INOUT) :: QLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_wd , jms:jme), INTENT(INOUT) :: TW1LEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_wd , jms:jme), INTENT(INOUT) :: TW2LEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_gbd, jms:jme), INTENT(INOUT) :: TGLEV_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_fbd, jms:jme), INTENT(INOUT) :: TFLEV_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LF_AC_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SF_AC_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CM_AC_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SFVENT_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LFVENT_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN1_URB3D - REAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: SFWIN2_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW1_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFW2_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFR_URB3D - REAL, DIMENSION(ims:ime, 1:num_urban_layers, jms:jme), INTENT(INOUT) :: SFG_URB3D + REAL, DIMENSION( ims:ime, 1:urban_map_wd, jms:jme), INTENT(INOUT) :: SFWIN1_URB3D + REAL, DIMENSION( ims:ime, 1:urban_map_wd, jms:jme), INTENT(INOUT) :: SFWIN2_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zd , jms:jme), INTENT(INOUT) :: SFW1_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zd , jms:jme), INTENT(INOUT) :: SFW2_URB3D + REAL, DIMENSION(ims:ime, 1:urban_map_zdf, jms:jme), INTENT(INOUT) :: SFR_URB3D + REAL, DIMENSION(ims:ime, 1:num_urban_ndm, jms:jme), INTENT(INOUT) :: SFG_URB3D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: EP_PV_URB3D!GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf,jms:jme ), INTENT(INOUT) :: T_PV_URB3D!GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme),INTENT(INOUT) :: TRV_URB4D ! GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zgrd, jms:jme),INTENT(INOUT) :: QR_URB4D ! GRZ + REAL, DIMENSION( ims:ime,jms:jme), INTENT(INOUT) :: QGR_URB3D ! GRZ + REAL, DIMENSION( ims:ime,jms:jme), INTENT(INOUT) :: TGR_URB3D ! GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme),INTENT(INOUT) :: DRAIN_URB4D !GRZ + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRAINGR_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme),INTENT(INOUT) :: SFRV_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme),INTENT(INOUT) :: LFRV_URB3D ! GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: DGR_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ),INTENT(INOUT) :: DG_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:urban_map_zdf, jms:jme ),INTENT(INOUT) :: LFR_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:num_urban_ndm, jms:jme ), INTENT(INOUT) :: LFG_URB3D !GRZ + REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(IN) ::SMOIS_URB + REAL, DIMENSION( ims:ime,1:num_urban_hi , jms:jme), INTENT(INOUT) :: HI_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LP_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: HGT_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: MH_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: STDH_URB2D + REAL, DIMENSION( ims:ime, 4,jms:jme ), INTENT(INOUT) :: LF_URB2D REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_U_BEP REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_V_BEP REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: A_T_BEP @@ -1995,8 +2627,12 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UTYPE_URB2D INTEGER :: UTYPE_URB +!FS + INTEGER :: SWITCH_URB + + INTEGER :: I,J,K,CHECK - INTEGER :: I,J,K + CHECK = 0 DO I=ims,ime DO J=jms,jme @@ -2012,28 +2648,89 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, RN_URB2D(I,J)=0. !m - FRC_URB2D(I,J)=0. +!FS FRC_URB2D(I,J)=0. UTYPE_URB2D(I,J)=0 + SWITCH_URB=1 IF( IVGTYP(I,J) == ISURBAN) THEN - UTYPE_URB2D(I,J) = 2 ! for default. high-intensity - UTYPE_URB = UTYPE_URB2D(I,J) ! for default. high-intensity - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) - ENDIF - IF( IVGTYP(I,J) == 31) THEN - UTYPE_URB2D(I,J) = 3 ! low-intensity residential - UTYPE_URB = UTYPE_URB2D(I,J) ! low-intensity residential - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) - ENDIF - IF( IVGTYP(I,J) == 32) THEN - UTYPE_URB2D(I,J) = 2 ! high-intensity - UTYPE_URB = UTYPE_URB2D(I,J) ! high-intensity - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + IF(use_wudapt_lcz==0) THEN + UTYPE_URB2D(I,J) = 2 ! for default. high-intensity + ELSE + UTYPE_URB2D(I,J) = 5 ! for default. high-intensity + ENDIF + ELSE IF( IVGTYP(I,J) == LCZ_1) THEN + UTYPE_URB2D(I,J) = 1 + ELSE IF( IVGTYP(I,J) == LCZ_2) THEN + UTYPE_URB2D(I,J) = 2 + ELSE IF( IVGTYP(I,J) == LCZ_3) THEN + UTYPE_URB2D(I,J) = 3 + ELSE IF( IVGTYP(I,J) == LCZ_4) THEN + UTYPE_URB2D(I,J) = 4 + ELSE IF( IVGTYP(I,J) == LCZ_5) THEN + UTYPE_URB2D(I,J) = 5 + ELSE IF( IVGTYP(I,J) == LCZ_6) THEN + UTYPE_URB2D(I,J) = 6 + ELSE IF( IVGTYP(I,J) == LCZ_7) THEN + UTYPE_URB2D(I,J) = 7 + ELSE IF( IVGTYP(I,J) == LCZ_8) THEN + UTYPE_URB2D(I,J) = 8 + ELSE IF( IVGTYP(I,J) == LCZ_9) THEN + UTYPE_URB2D(I,J) = 9 + ELSE IF( IVGTYP(I,J) == LCZ_10) THEN + UTYPE_URB2D(I,J) = 10 + ELSE IF( IVGTYP(I,J) == LCZ_11) THEN + UTYPE_URB2D(I,J) = 11 + ELSE + SWITCH_URB=0 ENDIF - IF( IVGTYP(I,J) == 33) THEN - UTYPE_URB2D(I,J) = 1 ! Commercial/Industrial/Transportation - UTYPE_URB = UTYPE_URB2D(I,J) ! Commercial/Industrial/Transportation - FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + + IF (SWITCH_URB == 1) THEN + UTYPE_URB = UTYPE_URB2D(I,J) ! for default. high-intensity + IF (HGT_URB2D(I,J)>0.) THEN + CONTINUE + ELSE + WRITE(mesg,*) 'USING DEFAULT URBAN MORPHOLOGY' + WRITE_MESSAGE(mesg) + LP_URB2D(I,J)=0. + LB_URB2D(I,J)=0. + HGT_URB2D(I,J)=0. + IF ( sf_urban_physics == 1 ) THEN + MH_URB2D(I,J)=0. + STDH_URB2D(I,J)=0. + DO K=1,4 + LF_URB2D(I,K,J)=0. + ENDDO + ELSE IF ( ( sf_urban_physics == 2 ) .or. ( sf_urban_physics == 3 ) ) THEN + DO K=1,num_urban_hi + HI_URB2D(I,K,J)=0. + ENDDO + ENDIF + ENDIF + IF (FRC_URB2D(I,J)>0.and.FRC_URB2D(I,J)<=1.) THEN + CONTINUE + ELSE + WRITE(mesg,*) 'WARNING, FRC_URB2D = 0 BUT IVGTYP IS URBAN' + WRITE_MESSAGE(mesg) + WRITE(mesg,*) 'WARNING, THE URBAN FRACTION WILL BE READ FROM URBPARM.TBL' + WRITE_MESSAGE(mesg) + FRC_URB2D(I,J) = FRC_URB_TBL(UTYPE_URB) + ENDIF + ELSE + FRC_URB2D(I,J)=0. + LP_URB2D(I,J)=0. + LB_URB2D(I,J)=0. + HGT_URB2D(I,J)=0. + IF ( sf_urban_physics == 1 ) THEN + MH_URB2D(I,J)=0. + STDH_URB2D(I,J)=0. + DO K=1,4 + LF_URB2D(I,K,J)=0. + ENDDO + ELSE IF ( ( sf_urban_physics == 2 ) .or. ( sf_urban_physics == 3 ) ) THEN + DO K=1,num_urban_hi + HI_URB2D(I,K,J)=0. + ENDDO + ENDIF ENDIF @@ -2046,6 +2743,16 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, XXXG_URB2D(I,J)=0. XXXC_URB2D(I,J)=0. + IF ( sf_urban_physics == 1 ) THEN + DRELR_URB2D(I,J) = 0. + DRELB_URB2D(I,J) = 0. + DRELG_URB2D(I,J) = 0. + FLXHUMR_URB2D(I,J) = 0. + FLXHUMB_URB2D(I,J) = 0. + FLXHUMG_URB2D(I,J) = 0. + CMCR_URB2D(I,J) = 0. + TGR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. + ENDIF TC_URB2D(I,J)=TSURFACE0_URB(I,J)+0. TR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. @@ -2054,7 +2761,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, ! TS_URB2D(I,J)=TSURFACE0_URB(I,J)+0. -! DO K=1,num_roof_layers +! DO K=1,num_roof_layers ! DO K=1,num_soil_layers ! TRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. ! TRL_URB3D(I,2,J)=TLAYER0_URB(I,2,J)+0. @@ -2065,6 +2772,18 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, TRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) TRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. TRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 + + IF ( sf_urban_physics == 1 ) THEN + TGRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. + TGRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) + TGRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. + TGRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 + + SMR_URB3D(I,1,J)=0.2 + SMR_URB3D(I,2,J)=0.2 + SMR_URB3D(I,3,J)=0.2 + SMR_URB3D(I,4,J)=0. + ENDIF ! END DO ! DO K=1,num_wall_layers @@ -2087,31 +2806,21 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, END DO ! multi-layer urban -! IF( sf_urban_physics .EQ. 2)THEN IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN - DO k=1,num_urban_layers -! TRB_URB4D(I,k,J)=TSURFACE0_URB(I,J) -! TW1_URB4D(I,k,J)=TSURFACE0_URB(I,J) -! TW2_URB4D(I,k,J)=TSURFACE0_URB(I,J) -! TGB_URB4D(I,k,J)=TSURFACE0_URB(I,J) -!MT TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J) -!MT TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J) -!MT TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J) IF (UTYPE_URB2D(I,J) > 0) THEN - TRB_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) - TW1_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) - TW2_URB4D(I,K,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + TRB_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + TW1_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + TW2_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) ELSE - TRB_URB4D(I,K,J)=tlayer0_urb(I,1,J) - TW1_URB4D(I,K,J)=tlayer0_urb(I,1,J) - TW2_URB4D(I,K,J)=tlayer0_urb(I,1,J) + TRB_URB4D(I,:,J)=tlayer0_urb(I,1,J) + TW1_URB4D(I,:,J)=tlayer0_urb(I,1,J) + TW2_URB4D(I,:,J)=tlayer0_urb(I,1,J) ENDIF - TGB_URB4D(I,K,J)=tlayer0_urb(I,1,J) - SFW1_URB3D(I,K,J)=0. - SFW2_URB3D(I,K,J)=0. - SFR_URB3D(I,K,J)=0. - SFG_URB3D(I,K,J)=0. - ENDDO + TGB_URB4D(I,:,J)=tlayer0_urb(I,1,J) + SFW1_URB3D(I,:,J)=0. + SFW2_URB3D(I,:,J)=0. + SFR_URB3D(I,:,J)=0. + SFG_URB3D(I,:,J)=0. ENDIF @@ -2121,22 +2830,40 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, CM_AC_URB3D(I,J)=0. SFVENT_URB3D(I,J)=0. LFVENT_URB3D(I,J)=0. + EP_PV_URB3D(I,J)=0. + T_PV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TGR_URB3D(I,J)=tlayer0_urb(I,1,J) + QR_URB4D(I,:,J)=SMOIS_URB(I,1,J) + DRAIN_URB4D(I,:,J)=0. !GRZ + SFRV_URB3D(I,:,J)=0. !GRZ + LFRV_URB3D(I,:,J)=0. !GRZ + DGR_URB3D(I,:,J)=0. !GRZ + DG_URB3D(I,:,J)=0. + LFR_URB3D(I,:,J)=0. + LFG_URB3D(I,:,J)=0. + QGR_URB3D(I,J)=SMOIS_URB(I,1,J) !GRZ + TGR_URB3D(I,J)=0. + DRAINGR_URB3D(I,J)=0. !GRZ + + IF (UTYPE_URB2D(I,J) > 0) THEN + TRV_URB4D(I,:,J)=TBLEND_TBL(UTYPE_URB2D(I,J)) + ELSE + TRV_URB4D(I,:,J)=tlayer0_urb(I,1,J) !GRZ + ENDIF - DO K=1,num_urban_layers - TLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TW1LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TW2LEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TGLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - TFLEV_URB3D(I,K,J)=tlayer0_urb(I,1,J) - QLEV_URB3D(I,K,J)=0.01 - SFWIN1_URB3D(I,K,J)=0. - SFWIN2_URB3D(I,K,J)=0. + TLEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TW1LEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TW2LEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TGLEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + TFLEV_URB3D(I,:,J)=tlayer0_urb(I,1,J) + QLEV_URB3D(I,:,J)=0.01 + SFWIN1_URB3D(I,:,J)=0. + SFWIN2_URB3D(I,:,J)=0. !rm LF_AC_URB3D(I,J)=0. !rm SF_AC_URB3D(I,J)=0. !rm CM_AC_URB3D(I,J)=0. !rm SFVENT_URB3D(I,J)=0. !rm LFVENT_URB3D(I,J)=0. - ENDDO endif @@ -2160,6 +2887,62 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, END DO ENDIF !sf_urban_physics=2 ENDIF !restart + + + IF (CHECK.EQ.0)THEN + IF(IVGTYP(I,J).EQ.1)THEN + write(mesg,*) 'Sample of Urban settings' + WRITE_MESSAGE(mesg) + write(mesg,*) 'TSURFACE0_URB',TSURFACE0_URB(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'TDEEP0_URB', TDEEP0_URB(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'IVGTYP',IVGTYP(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'TR_URB2D',TR_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'TB_URB2D',TB_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'TG_URB2D',TG_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'TC_URB2D',TC_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'QC_URB2D',QC_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'XXXR_URB2D',XXXR_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'SH_URB2D',SH_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'LH_URB2D',LH_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'G_URB2D',G_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'RN_URB2D',RN_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'TS_URB2D',TS_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'LF_AC_URB3D', LF_AC_URB3D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'SF_AC_URB3D', SF_AC_URB3D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'CM_AC_URB3D', CM_AC_URB3D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'SFVENT_URB3D', SFVENT_URB3D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'LFVENT_URB3D', LFVENT_URB3D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'FRC_URB2D', FRC_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'UTYPE_URB2D', UTYPE_URB2D(I,J) + WRITE_MESSAGE(mesg) + write(mesg,*) 'I',I,'J',J + WRITE_MESSAGE(mesg) + write(mesg,*) 'num_urban_hi', num_urban_hi + WRITE_MESSAGE(mesg) + CHECK = 1 + END IF + END IF + END DO END DO RETURN @@ -2424,4 +3207,856 @@ SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) END SUBROUTINE SFCDIF_URB ! ---------------------------------------------------------------------- !=========================================================================== +! DIREVAP +! CALCULATE DIRECT SOIL EVAPORATION +!=========================================================================== + SUBROUTINE DIREVAP (EDIR,ETP,SMC,SHDFAC,SMCMAX,SMCDRY,FXEXP) + + REAL, INTENT(IN) :: ETP,SMC,SHDFAC,SMCMAX,SMCDRY,FXEXP + REAL, INTENT(OUT) :: EDIR + REAL :: FX, SRATIO + +! ---------------------------------------------------------------------- +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO > 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + EDIR = FX * ( 1.0- SHDFAC ) * ETP * 0.001 + + END SUBROUTINE DIREVAP +!=========================================================================== +! TRANSP +! CALCULATE EVAPOTRANSPIRATION FOR VEGETATIO SURFACE +!=========================================================================== + + SUBROUTINE TRANSP (ETT,ET,EC,SHDFAC,ETP1,CMC,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,SX, & + TS,TA,QA,SMC,SMCWLT,SMCREF,CPP,PS,CH,EPSV,DELT, NROOT,NSOIL, & + DZVR, ZSOIL, HS) + INTEGER, INTENT(IN) :: NROOT, NSOIL + REAL, INTENT(IN) :: SHDFAC,ETP1,CMC,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,SX,TA + REAL, INTENT(IN) :: TS,QA, SMCWLT, SMCREF, CPP, PS,CH, EPSV, DELT, HS + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL, DZVR, SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: ET + REAL, INTENT(OUT) :: EC, ETT + REAL :: RC, RCS, RCT, RCQ, RCSOIL, FF, WS, SLV, DESDT + REAL :: SIGMA, PC, CMC2MS, SGX, DENOM, RTX, ETT1 + INTEGER :: K + REAL, DIMENSION(1:NROOT) :: PART, GX + + SLV = 2.501E+6 + SIGMA = 5.67E-8 + ETT = 0.0 + DO K = 1, NSOIL + ET(K) = 0. + END DO + +! ---------------------------------------------------------------------- +! INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS. +! ---------------------------------------------------------------------- + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 + RCSOIL = 0.0 + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO INCOMING SOLAR RADIATION +! ---------------------------------------------------------------------- + FF = 0.55*2.0* SX*697.7 * 60/ (RGL * LAI) + RCS = (FF + RSMIN / RSMAX) / (1.0+ FF) + RCS = MAX (RCS,0.0001) +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND +! RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR). +! ---------------------------------------------------------------------- + RCT = 1.0- 0.0016* ( (298 - TA)**2.0) + RCT = MAX (RCT,0.0001) +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL. +! RCQ EXPRESSION FROM SSIB (Niyogi and Raman, 1997) +! ---------------------------------------------------------------------- + EA = 6.11*EXP((2.5*10.**6./461.51)*(TA-273.15)/(273.15*TA) ) + WS = 0.622*EA/1013 + RCQ = 1.0/ (1.0+ HS * (WS - QA)) + RCQ = MAX (RCQ,0.01) +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY. +! DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP. +! ---------------------------------------------------------------------- + DO K = 1, NROOT + GX(K) = (SMC(K) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX(K) > 1.) GX(K) = 1. + IF (GX(K) < 0.) GX(K) = 0. + PART (K) = ( -DZVR (K)/ ZSOIL (3)) * GX(K) + END DO + + SGX =0.0 + DO K = 1, NROOT + SGX = SGX + GX (K) + RCSOIL = RCSOIL + PART (K) + END DO + SGX =SGX / NROOT + + RCSOIL = MAX (RCSOIL,0.0001) + + RC = RSMIN / (LAI * RCS * RCT * RCQ * RCSOIL) + DESDT = 0.622*SLV*EA/461.51/TA/TA/1013 + DELTA = (SLV / CPP)* DESDT + RR = (4.* EPSV *SIGMA * 287.04 / CPP)* (TA **4.)/ (TS * CH) + 1.0 + PC = (RR + DELTA)/ (RR * (1. + RC * CH) + DELTA) + + IF (CMC .ne. 0.0) THEN + ETT1 = SHDFAC * PC * ETP1 * (1.0- (CMC / CMCMAX) ** CFACTR) * 0.001 + ELSE + ETT1 = SHDFAC * PC * ETP1 * 0.001 + ENDIF + + DENOM = 0. + DO K = 1, NROOT + RTX= (-DZVR (K)/ ZSOIL (3)) + GX(K) - SGX + GX (K) = GX (K) * MAX ( RTX, 0. ) + DENOM = DENOM + GX (K) + END DO + IF (DENOM .le. 0.0) DENOM =1. + + DO K = 1, NROOT + ET(K) = ETT1 * GX (K) / DENOM + ETT = ETT + ET (K) + END DO + + + IF (CMC > 0.0) THEN + EC = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1 * 0.001 + ELSE + EC = 0.0 + END IF + CMC2MS = CMC / DELT + EC = MIN ( CMC2MS, EC ) + + END SUBROUTINE TRANSP +! ---------------------------------------------------------------------- +! SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SMFLX (SMCP,SMC,NSOIL,CMCP,CMC,DT,PRCP1,ZSOIL, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX,RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR,EC,ET,DRIP) + +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I,K + REAL, INTENT(IN) :: BEXP, CMCMAX, DKSAT,DWSAT, DT, EC, EDIR, & + PRCP1, SHDFAC, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3 + REAL, INTENT(IN) :: CMCP + REAL, INTENT(OUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL, ET + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMCP + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SMC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT + REAL :: EXCESS,PCPDRP,RHSCT,TRHSCT + + +! ---------------------------------------------------------------------- +! ADD PRECIPITATION TO EXISTING CMC.IF RESULTING AMT EXCEEDS MAX CAPACITY, +! IT BECOMES DRIP AND WILL FALL TO THE GRND. +! ---------------------------------------------------------------------- + RHSCT = SHDFAC * PRCP1 * 0.001 /3600. - EC + DRIP = 0. + TRHSCT = DT * RHSCT + EXCESS = CMCP + TRHSCT + +! ---------------------------------------------------------------------- +! PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMCP) THAT GOES INTO THE +! SOIL +! ---------------------------------------------------------------------- + IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX + PCPDRP = (1. - SHDFAC) * PRCP1 * 0.001 /3600. + DRIP / DT + +! ---------------------------------------------------------------------- +! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE +! TENDENCY EQUATIONS. +! ---------------------------------------------------------------------- + CALL SRT (RHSTT,EDIR,ET,SMCP,NSOIL,PCPDRP,ZSOIL,DWSAT,DKSAT, & + SMCMAX,BEXP,RUNOFF1,RUNOFF2,DT,SMCWLT,AI,BI,CI) + + CALL SSTEP (SMCP,SMC,CMCP,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,AI,BI,CI) +! ---------------------------------------------------------------------- + END SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SRT (RHSTT,EDIR,ET,SMCP,NSOIL,PCPDRP,ZSOIL,DWSAT, & + DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,AI,BI,CI) + +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K, KS + + REAL, INTENT(IN) :: BEXP, DKSAT, DT, DWSAT, EDIR, & + PCPDRP, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMCP, ZSOIL, ET + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DDMAX + REAL :: DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2, DSMDZ, DSMDZ2, DT1, & + INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX,SMCAV, SSTT, PAR, & + VAL, WCND, WCND2, WDF, WDF2,KDT + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- + + PDDUM = PCPDRP + RUNOFF1 = 0.0 + PAR = 2.0E-6 + + IF (PCPDRP /= 0.0) THEN + SMCAV = SMCMAX - SMCWLT + DDMAX (1) = - ZSOIL (1)* SMCAV + DDMAX (1) = DDMAX (1)* (1.0- (SMCP (1) - SMCWLT)/ SMCAV) + DDMAX (2) = (ZSOIL (1) - ZSOIL (2))* SMCAV + DDMAX (2) = DDMAX (2)* (1.0- (SMCP (2) - SMCWLT)/ SMCAV) + DDMAX (3) = (ZSOIL (2) - ZSOIL (3))* SMCAV + DDMAX (3) = DDMAX (3)* (1.0- (SMCP (3) - SMCWLT)/ SMCAV) + + DD = DDMAX(1)+DDMAX(2)+DDMAX(3) + DT1 = DT/86400 + KDT = 3.0 * DKSAT / PAR + VAL = (1. - EXP ( - KDT * DT1)) + DDT = DD * VAL + PX = PCPDRP * DT + IF (PX < 0.0) PX = 0.0 + + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + MXSMC = SMCP (1) + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT) + INFMAX = MAX (INFMAX,WCND) + INFMAX = MIN (INFMAX,PX/DT) + + + IF (PCPDRP > INFMAX) THEN + RUNOFF1 = PCPDRP - INFMAX + PDDUM = INFMAX + END IF + END IF +! ---------------------------------------------------------------------- +! TOP LAYER +! ---------------------------------------------------------------------- + CALL WDFCND (WDF,WCND,SMCP(1),SMCMAX,BEXP,DKSAT,DWSAT) + DDZ = 1. / ( - .5 * ZSOIL (2) ) + AI (1) = 0.0 + BI (1) = WDF * DDZ / ( - ZSOIL (1) ) + CI (1) = - BI (1) + DSMDZ = (SMCP (1) - SMCP (2) )/( - 0.5 * ZSOIL(2)) + RHSTT (1) = (WDF * DSMDZ + WCND- PDDUM + EDIR + ET(1))/ ZSOIL (1) + SSTT = WDF * DSMDZ + WCND+ EDIR + ET(1) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL-1 + DENOM2 = (ZSOIL (K -1) - ZSOIL (K)) + IF (K /= NSOIL-1) THEN + MXSMC2 = SMCP (K) + CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT) + DENOM = (ZSOIL (K -1) - ZSOIL (K +1)) + DSMDZ2 = (SMCP (K) - SMCP (K +1)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K) = - WDF2 * DDZ2 / DENOM2 + ELSE + CALL WDFCND (WDF2,WCND2,SMCP(NSOIL-1),SMCMAX,BEXP,DKSAT,DWSAT) + DSMDZ2 = 0.0 + CI (K) = 0.0 + END IF + NUMER = (WDF2 * DSMDZ2) - (WDF * DSMDZ) & + - WCND+ ET(K) + RHSTT (K) = NUMER / ( - DENOM2) + AI (K) = - WDF * DDZ / DENOM2 + BI (K) = - ( AI (K) + CI (K) ) + IF (K .eq. NSOIL-1) THEN + RUNOFF2 = 0.0 + END IF + IF (K .ne. NSOIL-1) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SRT +! ---------------------------------------------------------------------- + + SUBROUTINE SSTEP (SMCP,SMC,CMCP,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL, & + AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K, KK11 + + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX + REAL, INTENT(OUT) :: RUNOFF3 + REAL, INTENT(IN) :: CMCP + REAL, INTENT(OUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMCP, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTin, SMCOUT,SMCIN + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DDZ, RHSCT, WPLUS, STOT + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL-1 + RHSTT (K) = RHSTT (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL-1 + RHSTTin (K) = RHSTT (K) + END DO + DO K = 1,NSOIL-1 + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL-1) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + + DDZ = - ZSOIL (1) + DO K = 1,NSOIL-1 + IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) + SMCOUT (K) = SMCP (K) + CI (K) + WPLUS / DDZ + STOT = SMCOUT (K) + IF (STOT > SMCMAX) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K) + ZSOIL (KK11) + END IF + WPLUS = (STOT - SMCMAX) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K) = MAX ( MIN (STOT,SMCMAX),0.066 ) + END DO + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3 = WPLUS + CMC = CMCP + DT * RHSCT + IF (CMC < 1.E-20) CMC = 0.0 + CMC = MIN (CMC,CMCMAX) + +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT) + +! ---------------------------------------------------------------------- +! SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY. +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL BEXP + REAL DKSAT + REAL DWSAT + REAL EXPON + REAL FACTR1 + REAL FACTR2 + REAL SMC + REAL SMCMAX + REAL WCND + +! ---------------------------------------------------------------------- +! CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT +! ---------------------------------------------------------------------- + REAL WDF + FACTR1 = 0.05 / SMCMAX + +! ---------------------------------------------------------------------- +! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY AND CONDUCTIVITY +! ---------------------------------------------------------------------- + FACTR2 = SMC / SMCMAX + FACTR1 = MIN(FACTR1,FACTR2) + EXPON = BEXP + 2.0 + WDF = DWSAT * FACTR2 ** EXPON + EXPON = (2.0 * BEXP) + 3.0 + WCND = DKSAT * FACTR2 ** EXPON + +! ---------------------------------------------------------------------- + END SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K, KK + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: A, B, D + REAL, DIMENSION(1:NSOIL),INTENT(INOUT):: C,P,DELTA + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (1) = - C (1) / B (1) + DELTA (1) = D (1) / B (1) + DO K = 2,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) + +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + KK = NSOIL - K + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 +!---------------------------------------------------------------------- + + SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) + +! ---------------------------------------------------------------------- +! SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I + + REAL, INTENT(IN) :: DF1,DT,SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1, QUARTZ + REAL, INTENT(IN) :: CSOIL, CAPR + REAL, INTENT(INOUT) :: T1 + REAL, INTENT(OUT) :: SSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + ! Land case + + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + ZBOT,DT,DF1,AI,BI,CI,QUARTZ,CSOIL,CAPR) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + DO I = 1,NSOIL + STC (I) = STCF (I) + ENDDO + +! ---------------------------------------------------------------------- +! CALCULATE SURFACE SOIL HEAT FLUX +! ---------------------------------------------------------------------- + T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1 + SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1)) + +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! SUBROUTINE HRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + + SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & + TBOT,ZBOT,DT,DF1,AI,BI,CI,QUARTZ,CSOIL,CAPR) + + IMPLICIT NONE + LOGICAL :: ITAVG + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K + + REAL, INTENT(IN) :: DF1, DT,SMCMAX ,TBOT,YY,ZZ1, ZBOT, QUARTZ, CSOIL, CAPR + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,STC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI + REAL :: DDZ, DDZ2, DENOM, DF1K, DTSDZ,DF1N, & + DTSDZ2,HCPCT,QTOT,SSOIL,SICE,TAVG,TBK, & + TBK1,TSNSR,TSURF + REAL, PARAMETER :: CAIR = 1004.0, CH2O = 4.2E6 + + +! ---------------------------------------------------------------------- +! INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING. +! ---------------------------------------------------------------------- + ITAVG = .TRUE. + +! ---------------------------------------------------------------------- +! TOP SOIL LAYER +! ---------------------------------------------------------------------- + HCPCT = SMC (1)* CH2O + (1.0- SMCMAX)* CSOIL + (SMCMAX - SMC (1))& + * CAIR + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL +! LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1 / (0.5 * ZSOIL (1) * ZSOIL (1)* HCPCT * & + ZZ1) + DTSDZ = (STC (1) - STC (2)) / (-0.5 * ZSOIL (2)) + SSOIL = DF1 * (STC (1) - YY) / (0.5 * ZSOIL (1) * ZZ1) + DENOM = (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND +! BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT +! ---------------------------------------------------------------------- + RHSTS (1) = (DF1 * DTSDZ - SSOIL) / DENOM + QTOT = -1.0* RHSTS (1)* DENOM + IF (ITAVG) THEN + TSURF = (YY + (ZZ1-1) * STC (1)) / ZZ1 + CALL TBND (STC (1),STC (2),ZSOIL,ZBOT,1,NSOIL,TBK) + ENDIF + DDZ2 = 0.0 + DF1N = DF1 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS) +! ---------------------------------------------------------------------- + DO K = 2,NSOIL +! ---------------------------------------------------------------------- +! THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER. +! ---------------------------------------------------------------------- + IF (K < NSOIL-1 ) THEN + HCPCT = SMC (K)* CH2O + (1.0- SMCMAX)* CSOIL + (SMCMAX - SMC ( & + K))* CAIR + CALL TDFCND (DF1K, SMC(K), QUARTZ, SMCMAX) + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + DTSDZ2 = (STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAYER. +! ---------------------------------------------------------------------- + CI (K) = - DF1K * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * & + HCPCT) + IF (ITAVG) THEN + CALL TBND (STC (K),STC (K +1),ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF + + ELSEIF (K == NSOIL-1) THEN + + HCPCT = SMC (K)* CH2O + (1.0- SMCMAX)* CSOIL + (SMCMAX- SMC ( & + K))* CAIR + CALL TDFCND (DF1K, SMC(K), QUARTZ, SMCMAX) + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + DTSDZ2 = (STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) +!----------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + CI (K) = - DF1K * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * & + HCPCT) + IF (ITAVG) THEN + CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF + ELSE +! ---------------------------------------------------------------------- +! SPECIAL CASE OF BOTTOM LAYER (CONCRETE ROOF) +! ---------------------------------------------------------------------- + HCPCT = CAPR * 4.1868 * 1.E6 + DF1K = 3.24 +! ---------------------------------------------------------------------- +! CALC THE VERTICAL TEMP GRADIENT THRU BOTTOM LAYER. +! ---------------------------------------------------------------------- + DENOM = .5 * (ZSOIL (K -1) + ZSOIL (K)) - ZBOT + DTSDZ2 = (STC (K) - TBOT) / DENOM +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + CI (K) = 0. + IF (ITAVG) THEN + CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF +! ---------------------------------------------------------------------- +! THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER. + END IF +! ---------------------------------------------------------------------- +! CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + RHSTS (K) = ( DF1K * DTSDZ2- DF1N * DTSDZ ) / DENOM + QTOT = -1.0* DENOM * RHSTS (K) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + AI (K) = - DF1N * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + TBK = TBK1 + DF1N = DF1K + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRT +! ---------------------------------------------------------------------- + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: STCIN + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI,BI,CI + REAL, DIMENSION(1:NSOIL) :: RHSTSin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DT + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K) = RHSTS (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K) = RHSTS (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K) = STCIN (K) + CI (K) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + + SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) + +! ---------------------------------------------------------------------- +! SUBROUTINE TBND +! ---------------------------------------------------------------------- +! CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF +! THE MIDDLE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + REAL, INTENT(IN) :: TB, TU, ZBOT + REAL, INTENT(OUT) :: TBND1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL :: ZB, ZUP + +! ---------------------------------------------------------------------- +! USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER +! ---------------------------------------------------------------------- + IF (K == 1) THEN + ZUP = 0. + ELSE + ZUP = ZSOIL (K -1) + END IF +! ---------------------------------------------------------------------- +! USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE +! TEMPERATURE INTO THE LAST LAYER BOUNDARY +! ---------------------------------------------------------------------- + IF (K == NSOIL) THEN + ZB = 2.* ZBOT - ZSOIL (K) + ELSE + ZB = ZSOIL (K +1) + END IF +! ---------------------------------------------------------------------- +! LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + + TBND1 = TU + (TB - TU)* (ZUP - ZSOIL (K))/ (ZUP - ZB) +! ---------------------------------------------------------------------- + END SUBROUTINE TBND +! ---------------------------------------------------------------------- + SUBROUTINE TDFCND (DF, SMC, QZ, SMCMAX) +! ---------------------------------------------------------------------- +! CALCULATE THERMAL CONDUCTIVITY OF THE SOIL +! ---------------------------------------------------------------------- +! PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: QZ, SMC, SMCMAX + REAL, INTENT(OUT) :: DF + REAL :: AKE, GAMMD, THKDRY, THKO, & + THKQTZ,THKSAT,THKS,THKW,SATRATIO + +! ---------------------------------------------------------------------- +! IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT +! OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS +! ---------------------------------------------------------------------- +! THKW ......WATER THERMAL CONDUCTIVITY +! THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ +! THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS +! THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER) +! SMCMAX ....POROSITY (= SMCMAX) +! QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! ---------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). + +! PABLO GRUNMANN, 08/17/98 +! REFS.: +! FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK +! AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP. +! JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS, +! UNIVERSITY OF TRONDHEIM, +! PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL +! CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES +! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, +! VOL. 55, PP. 1209-1224. +! ---------------------------------------------------------------------- +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: +! PARAMETERS W/(M.K) + SATRATIO = SMC / SMCMAX +! WATER CONDUCTIVITY: + THKW = 0.57 +! THERMAL CONDUCTIVITY OF "OTHER" SOIL COMPONENTS +! IF (QZ .LE. 0.2) THKO = 3.0 + THKO = 2.0 +! QUARTZ' CONDUCTIVITY + THKQTZ = 7.7 +! SOLIDS' CONDUCTIVITY + THKS = (THKQTZ ** QZ)* (THKO ** (1. - QZ)) + +! SATURATED THERMAL CONDUCTIVITY + THKSAT = THKS ** (1. - SMCMAX)* THKW ** (SMCMAX) + +! DRY DENSITY IN KG/M3 + GAMMD = (1. - SMCMAX)*2700. + +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) + +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + + IF ( SATRATIO > 0.1 ) THEN + + AKE = LOG10 (SATRATIO) + 1.0 + +! USE K = KDRY + ELSE + + AKE = 0.0 + END IF +! THERMAL CONDUCTIVITY + + DF = AKE * (THKSAT - THKDRY) + THKDRY +! ---------------------------------------------------------------------- + END SUBROUTINE TDFCND +! ---------------------------------------------------------------------- +!=========================================================================== END MODULE module_sf_urban 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..5e9ab3f61b --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/sf_mynn_pre.F @@ -0,0 +1,169 @@ +!================================================================================================================= + module sf_mynn_pre + use ccpp_kind_types,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_atmosphere/physics/physics_wrf/sf_sfclayrev_pre.F b/src/core_atmosphere/physics/physics_wrf/sf_sfclayrev_pre.F new file mode 100644 index 0000000000..bff574dca5 --- /dev/null +++ b/src/core_atmosphere/physics/physics_wrf/sf_sfclayrev_pre.F @@ -0,0 +1,101 @@ +!================================================================================================================= + module sf_sfclayrev_pre + use ccpp_kind_types,only: kind_phys + + implicit none + private + public:: sf_sfclayrev_pre_init, & + sf_sfclayrev_pre_finalize, & + sf_sfclayrev_pre_run + + + contains + + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_pre_init +!!\html\include sf_sfclayrev_pre_init.html +!! + subroutine sf_sfclayrev_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_sfclayrev_pre_init + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_pre_finalize +!!\html\include sf_sfclayrev_pre_finalize.html +!! + subroutine sf_sfclayrev_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_sfclayrev_pre_finalize + +!================================================================================================================= +!>\section arg_table_sf_sfclayrev_pre_run +!!\html\include sf_sfclayrev_pre_run.html +!! + subroutine sf_sfclayrev_pre_run(dz2d,u2d,v2d,qv2d,p2d,t2d,dz1d,u1d,v1d,qv1d,p1d,t1d, & + its,ite,kts,kte,errmsg,errflg) +!================================================================================================================= + +!--- input arguments: + integer,intent(in):: its,ite,kts,kte + + real(kind=kind_phys),intent(in),dimension(its:ite,kts:kte):: & + dz2d,u2d,v2d,qv2d,p2d,t2d + +!--- output arguments: + character(len=*),intent(out):: errmsg + integer,intent(out):: errflg + + real(kind=kind_phys),intent(out),dimension(its:ite):: & + dz1d,u1d,v1d,qv1d,p1d,t1d + +!--- local variables: + integer:: i + +!----------------------------------------------------------------------------------------------------------------- + + do i = its,ite + dz1d(i) = dz2d(i,kts) + u1d(i) = u2d(i,kts) + v1d(i) = v2d(i,kts) + qv1d(i) = qv2d(i,kts) + p1d(i) = p2d(i,kts) + t1d(i) = t2d(i,kts) + enddo + + errmsg = 'sf_sfclayrev_pre_run OK' + errflg = 0 + + end subroutine sf_sfclayrev_pre_run + +!================================================================================================================= + end module sf_sfclayrev_pre +!================================================================================================================= diff --git a/src/core_atmosphere/tools/manage_externals/.gitignore b/src/core_atmosphere/tools/manage_externals/.gitignore new file mode 100644 index 0000000000..a71ac0cd75 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/.gitignore @@ -0,0 +1,17 @@ +# directories that are checked out by the tool +cime/ +cime_config/ +components/ + +# generated local files +*.log + +# editor files +*~ +*.bak + +# generated python files +*.pyc + +# test tmp file +test/tmp diff --git a/src/core_atmosphere/tools/manage_externals/LICENSE.txt b/src/core_atmosphere/tools/manage_externals/LICENSE.txt new file mode 100644 index 0000000000..665ee03fbc --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/LICENSE.txt @@ -0,0 +1,34 @@ +Copyright (c) 2017-2018, University Corporation for Atmospheric Research (UCAR) +All rights reserved. + +Developed by: + University Corporation for Atmospheric Research - National Center for Atmospheric Research + https://www2.cesm.ucar.edu/working-groups/sewg + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal with the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom +the Software is furnished to do so, subject to the following conditions: + + - Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimers. + - Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimers in the documentation + and/or other materials provided with the distribution. + - Neither the names of [Name of Development Group, UCAR], + nor the names of its contributors may be used to endorse or promote + products derived from this Software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/src/core_atmosphere/tools/manage_externals/README.md b/src/core_atmosphere/tools/manage_externals/README.md new file mode 100644 index 0000000000..9475301b5d --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/README.md @@ -0,0 +1,231 @@ +-- AUTOMATICALLY GENERATED FILE. DO NOT EDIT -- + +[![Build Status](https://travis-ci.org/ESMCI/manage_externals.svg?branch=master)](https://travis-ci.org/ESMCI/manage_externals)[![Coverage Status](https://coveralls.io/repos/github/ESMCI/manage_externals/badge.svg?branch=master)](https://coveralls.io/github/ESMCI/manage_externals?branch=master) +``` +usage: checkout_externals [-h] [-e [EXTERNALS]] [-o] [-S] [-v] [--backtrace] + [-d] [--no-logging] + +checkout_externals manages checking out groups of externals from revision +control based on a externals description file. By default only the +required externals are checkout out. + +Operations performed by manage_externals utilities are explicit and +data driven. checkout_externals will always make the working copy *exactly* +match what is in the externals file when modifying the working copy of +a repository. + +If checkout_externals isn't doing what you expected, double check the contents +of the externals description file. + +Running checkout_externals without the '--status' option will always attempt to +synchronize the working copy to exactly match the externals description. + +optional arguments: + -h, --help show this help message and exit + -e [EXTERNALS], --externals [EXTERNALS] + The externals description filename. Default: + Externals.cfg. + -o, --optional By default only the required externals are checked + out. This flag will also checkout the optional + externals. + -S, --status Output status of the repositories managed by + checkout_externals. By default only summary + information is provided. Use verbose output to see + details. + -v, --verbose Output additional information to the screen and log + file. This flag can be used up to two times, + increasing the verbosity level each time. + --backtrace DEVELOPER: show exception backtraces as extra + debugging output + -d, --debug DEVELOPER: output additional debugging information to + the screen and log file. + --no-logging DEVELOPER: disable logging. + +``` +NOTE: checkout_externals *MUST* be run from the root of the source tree it +is managing. For example, if you cloned a repository with: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +Then the root of the source tree is /path/to/some-project-dev. If you +obtained a sub-project via a checkout of another project: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +and you need to checkout the sub-project externals, then the root of the +source tree is /path/to/some-project-dev. Do *NOT* run checkout_externals +from within /path/to/some-project-dev/sub-project + +The root of the source tree will be referred to as `${SRC_ROOT}` below. + +# Supported workflows + + * Checkout all required components from the default externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals + + * To update all required components to the current values in the + externals description file, re-run checkout_externals: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals + + If there are *any* modifications to *any* working copy according + to the git or svn 'status' command, checkout_externals + will not update any external repositories. Modifications + include: modified files, added files, removed files, or missing + files. + + To avoid this safety check, edit the externals description file + and comment out the modified external block. + + * Checkout all required components from a user specified externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals --externals my-externals.cfg + + * Status summary of the repositories managed by checkout_externals: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals --status + + ./cime + s ./components/cism + ./components/mosart + e-o ./components/rtm + M ./src/fates + e-o ./tools/PTCLM + + where: + * column one indicates the status of the repository in relation + to the externals description file. + * column two indicates whether the working copy has modified files. + * column three shows how the repository is managed, optional or required + + Column one will be one of these values: + * s : out-of-sync : repository is checked out at a different commit + compared with the externals description + * e : empty : directory does not exist - checkout_externals has not been run + * ? : unknown : directory exists but .git or .svn directories are missing + + Column two will be one of these values: + * M : Modified : modified, added, deleted or missing files + * : blank / space : clean + * - : dash : no meaningful state, for empty repositories + + Column three will be one of these values: + * o : optional : optionally repository + * : blank / space : required repository + + * Detailed git or svn status of the repositories managed by checkout_externals: + + $ cd ${SRC_ROOT} + $ ./manage_externals/checkout_externals --status --verbose + +# Externals description file + + The externals description contains a list of the external + repositories that are used and their version control locations. The + file format is the standard ini/cfg configuration file format. Each + external is defined by a section containing the component name in + square brackets: + + * name (string) : component name, e.g. [cime], [cism], etc. + + Each section has the following keyword-value pairs: + + * required (boolean) : whether the component is a required checkout, + 'true' or 'false'. + + * local_path (string) : component path *relative* to where + checkout_externals is called. + + * protoctol (string) : version control protocol that is used to + manage the component. Valid values are 'git', 'svn', + 'externals_only'. + + Switching an external between different protocols is not + supported, e.g. from svn to git. To switch protocols, you need to + manually move the old working copy to a new location. + + Note: 'externals_only' will only process the external's own + external description file without trying to manage a repository + for the component. This is used for retreiving externals for + standalone components like cam and clm. If the source root of the + externals_only component is the same as the main source root, then + the local path must be set to '.', the unix current working + directory, e. g. 'local_path = .' + + * repo_url (string) : URL for the repository location, examples: + * https://svn-ccsm-models.cgd.ucar.edu/glc + * git@github.com:esmci/cime.git + * /path/to/local/repository + * . + + NOTE: To operate on only the local clone and and ignore remote + repositories, set the url to '.' (the unix current path), + i.e. 'repo_url = .' . This can be used to checkout a local branch + instead of the upstream branch. + + If a repo url is determined to be a local path (not a network url) + then user expansion, e.g. ~/, and environment variable expansion, + e.g. $HOME or $REPO_ROOT, will be performed. + + Relative paths are difficult to get correct, especially for mixed + use repos. It is advised that local paths expand to absolute paths. + If relative paths are used, they should be relative to one level + above local_path. If local path is 'src/foo', the the relative url + should be relative to 'src'. + + * tag (string) : tag to checkout + + * hash (string) : the git hash to checkout. Only applies to git + repositories. + + * branch (string) : branch to checkout from the specified + repository. Specifying a branch on a remote repository means that + checkout_externals will checkout the version of the branch in the remote, + not the the version in the local repository (if it exists). + + Note: one and only one of tag, branch hash must be supplied. + + * externals (string) : used to make manage_externals aware of + sub-externals required by an external. This is a relative path to + the external's root directory. For example, the main externals + description has an external checkout out at 'src/useful_library'. + useful_library requires additional externals to be complete. + Those additional externals are managed from the source root by the + externals description file pointed 'useful_library/sub-xternals.cfg', + Then the main 'externals' field in the top level repo should point to + 'sub-externals.cfg'. + Note that by default, `checkout_externals` will clone an external's + submodules. As a special case, the entry, `externals = None`, will + prevent this behavior. For more control over which externals are + checked out, create an externals file (and see the `from_submodule` + configuration entry below). + + * from_submodule (True / False) : used to pull the repo_url, local_path, + and hash properties for this external from the .gitmodules file in + this repository. Note that the section name (the entry in square + brackets) must match the name in the .gitmodules file. + If from_submodule is True, the protocol must be git and no repo_url, + local_path, hash, branch, or tag entries are allowed. + Default: False + + * sparse (string) : used to control a sparse checkout. This optional + entry should point to a filename (path relative to local_path) that + contains instructions on which repository paths to include (or + exclude) from the working tree. + See the "SPARSE CHECKOUT" section of https://git-scm.com/docs/git-read-tree + Default: sparse checkout is disabled + + * Lines begining with '#' or ';' are comments and will be ignored. + +# Obtaining this tool, reporting issues, etc. + + The master repository for manage_externals is + https://github.com/ESMCI/manage_externals. Any issues with this tool + should be reported there. diff --git a/src/core_atmosphere/tools/manage_externals/README_FIRST b/src/core_atmosphere/tools/manage_externals/README_FIRST new file mode 100644 index 0000000000..c8a47d7806 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/README_FIRST @@ -0,0 +1,54 @@ +CESM is comprised of a number of different components that are +developed and managed independently. Each component may have +additional 'external' dependancies and optional parts that are also +developed and managed independently. + +The checkout_externals.py tool manages retreiving and updating the +components and their externals so you have a complete set of source +files for the model. + +checkout_externals.py relies on a model description file that +describes what components are needed, where to find them and where to +put them in the source tree. The default file is called "CESM.xml" +regardless of whether you are checking out CESM or a standalone +component. + +checkout_externals requires access to git and svn repositories that +require authentication. checkout_externals may pass through +authentication requests, but it will not cache them for you. For the +best and most robust user experience, you should have svn and git +working without password authentication. See: + + https://help.github.com/articles/connecting-to-github-with-ssh/ + + ?svn ref? + +NOTE: checkout_externals.py *MUST* be run from the root of the source +tree it is managing. For example, if you cloned CLM with: + + $ git clone git@github.com/ncar/clm clm-dev + +Then the root of the source tree is /path/to/cesm-dev. If you obtained +CLM via an svn checkout of CESM and you need to checkout the CLM +externals, then the root of the source tree for CLM is: + + /path/to/cesm-dev/components/clm + +The root of the source tree will be referred to as ${SRC_ROOT} below. + +To get started quickly, checkout all required components from the +default model description file: + + $ cd ${SRC_ROOT} + $ ./checkout_cesm/checkout_externals.py + +For additional information about using checkout model, please see: + + ${SRC_ROOT}/checkout_cesm/README + +or run: + + $ cd ${SRC_ROOT} + $ ./checkout_cesm/checkout_externals.py --help + + diff --git a/src/core_atmosphere/tools/manage_externals/checkout_externals b/src/core_atmosphere/tools/manage_externals/checkout_externals new file mode 100755 index 0000000000..536c64eb65 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/checkout_externals @@ -0,0 +1,43 @@ +#!/usr/bin/env python3 + +"""Main driver wrapper around the manic/checkout utility. + +Tool to assemble external respositories represented in an externals +description file. + +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import sys +import traceback +import os +import manic + +if sys.hexversion < 0x02070000: + print(70 * '*') + print('ERROR: {0} requires python >= 2.7.x. '.format(sys.argv[0])) + print('It appears that you are running python {0}'.format( + '.'.join(str(x) for x in sys.version_info[0:3]))) + print(70 * '*') + sys.exit(1) + + +if __name__ == '__main__': + ARGS = manic.checkout.commandline_arguments() + if ARGS.version: + version_info = '' + version_file_path = os.path.join(os.path.dirname(__file__),'version.txt') + with open(version_file_path) as f: + version_info = f.readlines()[0].strip() + print(version_info) + sys.exit(0) + try: + RET_STATUS, _ = manic.checkout.main(ARGS) + sys.exit(RET_STATUS) + except Exception as error: # pylint: disable=broad-except + manic.printlog(str(error)) + if ARGS.backtrace: + traceback.print_exc() + sys.exit(1) diff --git a/src/core_atmosphere/tools/manage_externals/manic/__init__.py b/src/core_atmosphere/tools/manage_externals/manic/__init__.py new file mode 100644 index 0000000000..11badedd3b --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/__init__.py @@ -0,0 +1,9 @@ +"""Public API for the manage_externals library +""" + +from manic import checkout +from manic.utils import printlog + +__all__ = [ + 'checkout', 'printlog', +] diff --git a/src/core_atmosphere/tools/manage_externals/manic/checkout.py b/src/core_atmosphere/tools/manage_externals/manic/checkout.py new file mode 100755 index 0000000000..25c05ea233 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/checkout.py @@ -0,0 +1,449 @@ +#!/usr/bin/env python3 + +""" +Tool to assemble repositories represented in a model-description file. + +If loaded as a module (e.g., in a component's buildcpp), it can be used +to check the validity of existing subdirectories and load missing sources. +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import argparse +import logging +import os +import os.path +import sys + +from manic.externals_description import create_externals_description +from manic.externals_description import read_externals_description_file +from manic.externals_status import check_safe_to_update_repos +from manic.sourcetree import SourceTree +from manic.utils import printlog, fatal_error +from manic.global_constants import VERSION_SEPERATOR, LOG_FILE_NAME + +if sys.hexversion < 0x02070000: + print(70 * '*') + print('ERROR: {0} requires python >= 2.7.x. '.format(sys.argv[0])) + print('It appears that you are running python {0}'.format( + VERSION_SEPERATOR.join(str(x) for x in sys.version_info[0:3]))) + print(70 * '*') + sys.exit(1) + + +# --------------------------------------------------------------------- +# +# User input +# +# --------------------------------------------------------------------- +def commandline_arguments(args=None): + """Process the command line arguments + + Params: args - optional args. Should only be used during systems + testing. + + Returns: processed command line arguments + """ + description = ''' + +%(prog)s manages checking out groups of externals from revision +control based on an externals description file. By default only the +required externals are checkout out. + +Running %(prog)s without the '--status' option will always attempt to +synchronize the working copy to exactly match the externals description. +''' + + epilog = ''' +``` +NOTE: %(prog)s *MUST* be run from the root of the source tree it +is managing. For example, if you cloned a repository with: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +Then the root of the source tree is /path/to/some-project-dev. If you +obtained a sub-project via a checkout of another project: + + $ git clone git@github.com/{SOME_ORG}/some-project some-project-dev + +and you need to checkout the sub-project externals, then the root of the +source tree remains /path/to/some-project-dev. Do *NOT* run %(prog)s +from within /path/to/some-project-dev/sub-project + +The root of the source tree will be referred to as `${SRC_ROOT}` below. + + +# Supported workflows + + * Checkout all required components from the default externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s + + * To update all required components to the current values in the + externals description file, re-run %(prog)s: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s + + If there are *any* modifications to *any* working copy according + to the git or svn 'status' command, %(prog)s + will not update any external repositories. Modifications + include: modified files, added files, removed files, or missing + files. + + To avoid this safety check, edit the externals description file + and comment out the modified external block. + + * Checkout all required components from a user specified externals + description file: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s --externals my-externals.cfg + + * Status summary of the repositories managed by %(prog)s: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s --status + + ./cime + s ./components/cism + ./components/mosart + e-o ./components/rtm + M ./src/fates + e-o ./tools/PTCLM + + + where: + * column one indicates the status of the repository in relation + to the externals description file. + * column two indicates whether the working copy has modified files. + * column three shows how the repository is managed, optional or required + + Column one will be one of these values: + * s : out-of-sync : repository is checked out at a different commit + compared with the externals description + * e : empty : directory does not exist - %(prog)s has not been run + * ? : unknown : directory exists but .git or .svn directories are missing + + Column two will be one of these values: + * M : Modified : modified, added, deleted or missing files + * : blank / space : clean + * - : dash : no meaningful state, for empty repositories + + Column three will be one of these values: + * o : optional : optionally repository + * : blank / space : required repository + + * Detailed git or svn status of the repositories managed by %(prog)s: + + $ cd ${SRC_ROOT} + $ ./manage_externals/%(prog)s --status --verbose + +# Externals description file + + The externals description contains a list of the external + repositories that are used and their version control locations. The + file format is the standard ini/cfg configuration file format. Each + external is defined by a section containing the component name in + square brackets: + + * name (string) : component name, e.g. [cime], [cism], etc. + + Each section has the following keyword-value pairs: + + * required (boolean) : whether the component is a required checkout, + 'true' or 'false'. + + * local_path (string) : component path *relative* to where + %(prog)s is called. + + * protoctol (string) : version control protocol that is used to + manage the component. Valid values are 'git', 'svn', + 'externals_only'. + + Switching an external between different protocols is not + supported, e.g. from svn to git. To switch protocols, you need to + manually move the old working copy to a new location. + + Note: 'externals_only' will only process the external's own + external description file without trying to manage a repository + for the component. This is used for retrieving externals for + standalone components like cam and ctsm which also serve as + sub-components within a larger project. If the source root of the + externals_only component is the same as the main source root, then + the local path must be set to '.', the unix current working + directory, e. g. 'local_path = .' + + * repo_url (string) : URL for the repository location, examples: + * https://svn-ccsm-models.cgd.ucar.edu/glc + * git@github.com:esmci/cime.git + * /path/to/local/repository + * . + + NOTE: To operate on only the local clone and and ignore remote + repositories, set the url to '.' (the unix current path), + i.e. 'repo_url = .' . This can be used to checkout a local branch + instead of the upstream branch. + + If a repo url is determined to be a local path (not a network url) + then user expansion, e.g. ~/, and environment variable expansion, + e.g. $HOME or $REPO_ROOT, will be performed. + + Relative paths are difficult to get correct, especially for mixed + use repos. It is advised that local paths expand to absolute paths. + If relative paths are used, they should be relative to one level + above local_path. If local path is 'src/foo', the the relative url + should be relative to 'src'. + + * tag (string) : tag to checkout + + * hash (string) : the git hash to checkout. Only applies to git + repositories. + + * branch (string) : branch to checkout from the specified + repository. Specifying a branch on a remote repository means that + %(prog)s will checkout the version of the branch in the remote, + not the the version in the local repository (if it exists). + + Note: one and only one of tag, branch hash must be supplied. + + * externals (string) : used to make manage_externals aware of + sub-externals required by an external. This is a relative path to + the external's root directory. For example, if LIBX is often used + as a sub-external, it might have an externals file (for its + externals) called Externals_LIBX.cfg. To use libx as a standalone + checkout, it would have another file, Externals.cfg with the + following entry: + + [ libx ] + local_path = . + protocol = externals_only + externals = Externals_LIBX.cfg + required = True + + Now, %(prog)s will process Externals.cfg and also process + Externals_LIBX.cfg as if it was a sub-external. + + Note that by default, checkout_externals will clone an external's + submodules. As a special case, the entry, "externals = None", will + prevent this behavior. For more control over which externals are + checked out, create an externals file (and see the from_submodule + configuration entry below). + + * from_submodule (True / False) : used to pull the repo_url, local_path, + and hash properties for this external from the .gitmodules file in + this repository. Note that the section name (the entry in square + brackets) must match the name in the .gitmodules file. + If from_submodule is True, the protocol must be git and no repo_url, + local_path, hash, branch, or tag entries are allowed. + Default: False + + * sparse (string) : used to control a sparse checkout. This optional + entry should point to a filename (path relative to local_path) that + contains instructions on which repository paths to include (or + exclude) from the working tree. + See the "SPARSE CHECKOUT" section of https://git-scm.com/docs/git-read-tree + Default: sparse checkout is disabled + + * Lines beginning with '#' or ';' are comments and will be ignored. + +# Obtaining this tool, reporting issues, etc. + + The master repository for manage_externals is + https://github.com/ESMCI/manage_externals. Any issues with this tool + should be reported there. + +# Troubleshooting + +Operations performed by manage_externals utilities are explicit and +data driven. %(prog)s will always attempt to make the working copy +*exactly* match what is in the externals file when modifying the +working copy of a repository. + +If %(prog)s is not doing what you expected, double check the contents +of the externals description file or examine the output of +./manage_externals/%(prog)s --status + +''' + + parser = argparse.ArgumentParser( + description=description, epilog=epilog, + formatter_class=argparse.RawDescriptionHelpFormatter) + + # + # user options + # + parser.add_argument("components", nargs="*", + help="Specific component(s) to checkout. By default, " + "all required externals are checked out.") + + parser.add_argument('-e', '--externals', nargs='?', + default='Externals.cfg', + help='The externals description filename. ' + 'Default: %(default)s.') + + parser.add_argument('-x', '--exclude', nargs='*', + help='Component(s) listed in the externals file which should be ignored.') + + parser.add_argument('-o', '--optional', action='store_true', default=False, + help='By default only the required externals ' + 'are checked out. This flag will also checkout the ' + 'optional externals.') + + parser.add_argument('-S', '--status', action='store_true', default=False, + help='Output the status of the repositories managed by ' + '%(prog)s. By default only summary information ' + 'is provided. Use the verbose option to see details.') + + parser.add_argument('-v', '--verbose', action='count', default=0, + help='Output additional information to ' + 'the screen and log file. This flag can be ' + 'used up to two times, increasing the ' + 'verbosity level each time.') + + parser.add_argument('--version', action='store_true', default=False, + help='Print manage_externals version and exit.') + + parser.add_argument('--svn-ignore-ancestry', action='store_true', default=False, + help='By default, subversion will abort if a component is ' + 'already checked out and there is no common ancestry with ' + 'the new URL. This flag passes the "--ignore-ancestry" flag ' + 'to the svn switch call. (This is not recommended unless ' + 'you are sure about what you are doing.)') + + # + # developer options + # + parser.add_argument('--backtrace', action='store_true', + help='DEVELOPER: show exception backtraces as extra ' + 'debugging output') + + parser.add_argument('-d', '--debug', action='store_true', default=False, + help='DEVELOPER: output additional debugging ' + 'information to the screen and log file.') + + logging_group = parser.add_mutually_exclusive_group() + + logging_group.add_argument('--logging', dest='do_logging', + action='store_true', + help='DEVELOPER: enable logging.') + logging_group.add_argument('--no-logging', dest='do_logging', + action='store_false', default=False, + help='DEVELOPER: disable logging ' + '(this is the default)') + + if args: + options = parser.parse_args(args) + else: + options = parser.parse_args() + return options + +def _dirty_local_repo_msg(program_name, config_file): + return """The external repositories labeled with 'M' above are not in a clean state. +The following are four options for how to proceed: +(1) Go into each external that is not in a clean state and issue either a 'git status' or + an 'svn status' command (depending on whether the external is managed by git or + svn). Either revert or commit your changes so that all externals are in a clean + state. (To revert changes in git, follow the instructions given when you run 'git + status'.) (Note, though, that it is okay to have untracked files in your working + directory.) Then rerun {program_name}. +(2) Alternatively, you do not have to rely on {program_name}. Instead, you can manually + update out-of-sync externals (labeled with 's' above) as described in the + configuration file {config_file}. (For example, run 'git fetch' and 'git checkout' + commands to checkout the appropriate tags for each external, as given in + {config_file}.) +(3) You can also use {program_name} to manage most, but not all externals: You can specify + one or more externals to ignore using the '-x' or '--exclude' argument to + {program_name}. Excluding externals labeled with 'M' will allow {program_name} to + update the other, non-excluded externals. +(4) As a last resort, if you are confident that there is no work that needs to be saved + from a given external, you can remove that external (via "rm -rf [directory]") and + then rerun the {program_name} tool. This option is mainly useful as a workaround for + issues with this tool (such as https://github.com/ESMCI/manage_externals/issues/157). +The external repositories labeled with '?' above are not under version +control using the expected protocol. If you are sure you want to switch +protocols, and you don't have any work you need to save from this +directory, then run "rm -rf [directory]" before rerunning the +{program_name} tool. +""".format(program_name=program_name, config_file=config_file) +# --------------------------------------------------------------------- +# +# main +# +# --------------------------------------------------------------------- +def main(args): + """ + Function to call when module is called from the command line. + Parse externals file and load required repositories or all repositories if + the --all option is passed. + + Returns a tuple (overall_status, tree_status). overall_status is 0 + on success, non-zero on failure. tree_status is a dict mapping local path + to ExternalStatus -- if no checkout is happening. If checkout is happening, tree_status + is None. + """ + if args.do_logging: + logging.basicConfig(filename=LOG_FILE_NAME, + format='%(levelname)s : %(asctime)s : %(message)s', + datefmt='%Y-%m-%d %H:%M:%S', + level=logging.DEBUG) + + program_name = os.path.basename(sys.argv[0]) + logging.info('Beginning of %s', program_name) + + load_all = False + if args.optional: + load_all = True + + root_dir = os.path.abspath(os.getcwd()) + model_data = read_externals_description_file(root_dir, args.externals) + ext_description = create_externals_description( + model_data, components=args.components, exclude=args.exclude) + + for comp in args.components: + if comp not in ext_description.keys(): + # Note we can't print out the list of found externals because + # they were filtered in create_externals_description above. + fatal_error( + "No component {} found in {}".format( + comp, args.externals)) + + source_tree = SourceTree(root_dir, ext_description, svn_ignore_ancestry=args.svn_ignore_ancestry) + if args.components: + components_str = 'specified components' + else: + components_str = 'required & optional components' + printlog('Checking local status of ' + components_str + ': ', end='') + tree_status = source_tree.status(print_progress=True) + printlog('') + + if args.status: + # user requested status-only + for comp in sorted(tree_status): + tree_status[comp].log_status_message(args.verbose) + else: + # checkout / update the external repositories. + safe_to_update = check_safe_to_update_repos(tree_status) + if not safe_to_update: + # print status + for comp in sorted(tree_status): + tree_status[comp].log_status_message(args.verbose) + # exit gracefully + printlog('-' * 70) + printlog(_dirty_local_repo_msg(program_name, args.externals)) + printlog('-' * 70) + else: + if not args.components: + source_tree.checkout(args.verbose, load_all) + for comp in args.components: + source_tree.checkout(args.verbose, load_all, load_comp=comp) + printlog('') + # New tree status is unknown, don't return anything. + tree_status = None + + logging.info('%s completed without exceptions.', program_name) + # NOTE(bja, 2017-11) tree status is used by the systems tests + return 0, tree_status diff --git a/src/core_atmosphere/tools/manage_externals/manic/externals_description.py b/src/core_atmosphere/tools/manage_externals/manic/externals_description.py new file mode 100644 index 0000000000..546e7fdcb4 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/externals_description.py @@ -0,0 +1,830 @@ +#!/usr/bin/env python3 + +"""Model description + +Model description is the representation of the various externals +included in the model. It processes in input data structure, and +converts it into a standard interface that is used by the rest of the +system. + +To maintain backward compatibility, externals description files should +follow semantic versioning rules, http://semver.org/ + + + +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import logging +import os +import os.path +import re + +# ConfigParser in python2 was renamed to configparser in python3. +# In python2, ConfigParser returns byte strings, str, instead of unicode. +# We need unicode to be compatible with xml and json parser and python3. +try: + # python2 + from ConfigParser import SafeConfigParser as config_parser + from ConfigParser import MissingSectionHeaderError + from ConfigParser import NoSectionError, NoOptionError + + USE_PYTHON2 = True + + def config_string_cleaner(text): + """convert strings into unicode + """ + return text.decode('utf-8') +except ImportError: + # python3 + from configparser import ConfigParser as config_parser + from configparser import MissingSectionHeaderError + from configparser import NoSectionError, NoOptionError + + USE_PYTHON2 = False + + def config_string_cleaner(text): + """Python3 already uses unicode strings, so just return the string + without modification. + + """ + return text + +from .utils import printlog, fatal_error, str_to_bool, expand_local_url +from .utils import execute_subprocess +from .global_constants import EMPTY_STR, PPRINTER, VERSION_SEPERATOR + +# +# Globals +# +DESCRIPTION_SECTION = 'externals_description' +VERSION_ITEM = 'schema_version' + + +def read_externals_description_file(root_dir, file_name): + """Read a file containing an externals description and + create its internal representation. + + """ + root_dir = os.path.abspath(root_dir) + msg = 'In directory : {0}'.format(root_dir) + logging.info(msg) + printlog('Processing externals description file : {0} ({1})'.format(file_name, + root_dir)) + + file_path = os.path.join(root_dir, file_name) + if not os.path.exists(file_name): + if file_name.lower() == "none": + msg = ('INTERNAL ERROR: Attempt to read externals file ' + 'from {0} when not configured'.format(file_path)) + else: + msg = ('ERROR: Model description file, "{0}", does not ' + 'exist at path:\n {1}\nDid you run from the root of ' + 'the source tree?'.format(file_name, file_path)) + + fatal_error(msg) + + externals_description = None + if file_name == ExternalsDescription.GIT_SUBMODULES_FILENAME: + externals_description = _read_gitmodules_file(root_dir, file_name) + else: + try: + config = config_parser() + config.read(file_path) + externals_description = config + except MissingSectionHeaderError: + # not a cfg file + pass + + if externals_description is None: + msg = 'Unknown file format!' + fatal_error(msg) + + return externals_description + +class LstripReader(object): + "LstripReader formats .gitmodules files to be acceptable for configparser" + def __init__(self, filename): + with open(filename, 'r') as infile: + lines = infile.readlines() + self._lines = list() + self._num_lines = len(lines) + self._index = 0 + for line in lines: + self._lines.append(line.lstrip()) + + def readlines(self): + """Return all the lines from this object's file""" + return self._lines + + def readline(self, size=-1): + """Format and return the next line or raise StopIteration""" + try: + line = self.next() + except StopIteration: + line = '' + + if (size > 0) and (len(line) < size): + return line[0:size] + + return line + + def __iter__(self): + """Begin an iteration""" + self._index = 0 + return self + + def next(self): + """Return the next line or raise StopIteration""" + if self._index >= self._num_lines: + raise StopIteration + + self._index = self._index + 1 + return self._lines[self._index - 1] + + def __next__(self): + return self.next() + +def git_submodule_status(repo_dir): + """Run the git submodule status command to obtain submodule hashes. + """ + # This function is here instead of GitRepository to avoid a dependency loop + cmd = 'git -C {repo_dir} submodule status'.format( + repo_dir=repo_dir).split() + git_output = execute_subprocess(cmd, output_to_caller=True) + submodules = {} + submods = git_output.split('\n') + for submod in submods: + if submod: + status = submod[0] + items = submod[1:].split(' ') + if len(items) > 2: + tag = items[2] + else: + tag = None + + submodules[items[1]] = {'hash':items[0], 'status':status, 'tag':tag} + + return submodules + +def parse_submodules_desc_section(section_items, file_path): + """Find the path and url for this submodule description""" + path = None + url = None + for item in section_items: + name = item[0].strip().lower() + if name == 'path': + path = item[1].strip() + elif name == 'url': + url = item[1].strip() + elif name == 'branch': + # We do not care about branch since we have a hash - silently ignore + pass + else: + msg = 'WARNING: Ignoring unknown {} property, in {}' + msg = msg.format(item[0], file_path) # fool pylint + logging.warning(msg) + + return path, url + +def _read_gitmodules_file(root_dir, file_name): + # pylint: disable=deprecated-method + # Disabling this check because the method is only used for python2 + # pylint: disable=too-many-locals + # pylint: disable=too-many-branches + # pylint: disable=too-many-statements + """Read a .gitmodules file and convert it to be compatible with an + externals description. + """ + root_dir = os.path.abspath(root_dir) + msg = 'In directory : {0}'.format(root_dir) + logging.info(msg) + + file_path = os.path.join(root_dir, file_name) + if not os.path.exists(file_name): + msg = ('ERROR: submodules description file, "{0}", does not ' + 'exist in dir:\n {1}'.format(file_name, root_dir)) + fatal_error(msg) + + submodules_description = None + externals_description = None + try: + config = config_parser() + if USE_PYTHON2: + config.readfp(LstripReader(file_path), filename=file_name) + else: + config.read_file(LstripReader(file_path), source=file_name) + + submodules_description = config + except MissingSectionHeaderError: + # not a cfg file + pass + + if submodules_description is None: + msg = 'Unknown file format!' + fatal_error(msg) + else: + # Convert the submodules description to an externals description + externals_description = config_parser() + # We need to grab all the commit hashes for this repo + submods = git_submodule_status(root_dir) + for section in submodules_description.sections(): + if section[0:9] == 'submodule': + sec_name = section[9:].strip(' "') + externals_description.add_section(sec_name) + section_items = submodules_description.items(section) + path, url = parse_submodules_desc_section(section_items, + file_path) + + if path is None: + msg = 'Submodule {} missing path'.format(sec_name) + fatal_error(msg) + + if url is None: + msg = 'Submodule {} missing url'.format(sec_name) + fatal_error(msg) + + externals_description.set(sec_name, + ExternalsDescription.PATH, path) + externals_description.set(sec_name, + ExternalsDescription.PROTOCOL, 'git') + externals_description.set(sec_name, + ExternalsDescription.REPO_URL, url) + externals_description.set(sec_name, + ExternalsDescription.REQUIRED, 'True') + if sec_name in submods: + submod_name = sec_name + else: + # The section name does not have to match the path + submod_name = path + + if submod_name in submods: + git_hash = submods[submod_name]['hash'] + externals_description.set(sec_name, + ExternalsDescription.HASH, + git_hash) + else: + emsg = "submodule status has no section, '{}'" + emsg += "\nCheck section names in externals config file" + fatal_error(emsg.format(submod_name)) + + # Required items + externals_description.add_section(DESCRIPTION_SECTION) + externals_description.set(DESCRIPTION_SECTION, VERSION_ITEM, '1.0.0') + + return externals_description + +def create_externals_description( + model_data, model_format='cfg', components=None, exclude=None, parent_repo=None): + """Create the a externals description object from the provided data + + components: list of component names to include, None to include all. If a + name isn't found, it is silently omitted from the return value. + exclude: list of component names to skip. + """ + externals_description = None + if model_format == 'dict': + externals_description = ExternalsDescriptionDict( + model_data, components=components, exclude=exclude) + elif model_format == 'cfg': + major, _, _ = get_cfg_schema_version(model_data) + if major == 1: + externals_description = ExternalsDescriptionConfigV1( + model_data, components=components, exclude=exclude, parent_repo=parent_repo) + else: + msg = ('Externals description file has unsupported schema ' + 'version "{0}".'.format(major)) + fatal_error(msg) + else: + msg = 'Unknown model data format "{0}"'.format(model_format) + fatal_error(msg) + return externals_description + + +def get_cfg_schema_version(model_cfg): + """Extract the major, minor, patch version of the config file schema + + Params: + model_cfg - config parser object containing the externas description data + + Returns: + major = integer major version + minor = integer minor version + patch = integer patch version + """ + semver_str = '' + try: + semver_str = model_cfg.get(DESCRIPTION_SECTION, VERSION_ITEM) + except (NoSectionError, NoOptionError): + msg = ('externals description file must have the required ' + 'section: "{0}" and item "{1}"'.format(DESCRIPTION_SECTION, + VERSION_ITEM)) + fatal_error(msg) + + # NOTE(bja, 2017-11) Assume we don't care about the + # build/pre-release metadata for now! + version_list = re.split(r'[-+]', semver_str) + version_str = version_list[0] + version = version_str.split(VERSION_SEPERATOR) + try: + major = int(version[0].strip()) + minor = int(version[1].strip()) + patch = int(version[2].strip()) + except ValueError: + msg = ('Config file schema version must have integer digits for ' + 'major, minor and patch versions. ' + 'Received "{0}"'.format(version_str)) + fatal_error(msg) + return major, minor, patch + + +class ExternalsDescription(dict): + """Base externals description class that is independent of the user input + format. Different input formats can all be converted to this + representation to provide a consistent represtentation for the + rest of the objects in the system. + + NOTE(bja, 2018-03): do NOT define _schema_major etc at the class + level in the base class. The nested/recursive nature of externals + means different schema versions may be present in a single run! + + All inheriting classes must overwrite: + self._schema_major and self._input_major + self._schema_minor and self._input_minor + self._schema_patch and self._input_patch + + where _schema_x is the supported schema, _input_x is the user + input value. + + """ + # keywords defining the interface into the externals description data; these + # are brought together by the schema below. + EXTERNALS = 'externals' # path to externals file. + BRANCH = 'branch' + SUBMODULE = 'from_submodule' + HASH = 'hash' + NAME = 'name' + PATH = 'local_path' + PROTOCOL = 'protocol' + REPO = 'repo' + REPO_URL = 'repo_url' + REQUIRED = 'required' + TAG = 'tag' + SPARSE = 'sparse' + + PROTOCOL_EXTERNALS_ONLY = 'externals_only' + PROTOCOL_GIT = 'git' + PROTOCOL_SVN = 'svn' + GIT_SUBMODULES_FILENAME = '.gitmodules' + KNOWN_PRROTOCOLS = [PROTOCOL_GIT, PROTOCOL_SVN, PROTOCOL_EXTERNALS_ONLY] + + # v1 xml keywords + _V1_TREE_PATH = 'TREE_PATH' + _V1_ROOT = 'ROOT' + _V1_TAG = 'TAG' + _V1_BRANCH = 'BRANCH' + _V1_REQ_SOURCE = 'REQ_SOURCE' + + # Dictionary keys are component names. The corresponding values are laid out + # according to this schema. + _source_schema = {REQUIRED: True, + PATH: 'string', + EXTERNALS: 'string', + SUBMODULE : True, + REPO: {PROTOCOL: 'string', + REPO_URL: 'string', + TAG: 'string', + BRANCH: 'string', + HASH: 'string', + SPARSE: 'string', + } + } + + def __init__(self, parent_repo=None): + """Convert the xml into a standardized dict that can be used to + construct the source objects + + """ + dict.__init__(self) + + self._schema_major = None + self._schema_minor = None + self._schema_patch = None + self._input_major = None + self._input_minor = None + self._input_patch = None + self._parent_repo = parent_repo + + def _verify_schema_version(self): + """Use semantic versioning rules to verify we can process this schema. + + """ + known = '{0}.{1}.{2}'.format(self._schema_major, + self._schema_minor, + self._schema_patch) + received = '{0}.{1}.{2}'.format(self._input_major, + self._input_minor, + self._input_patch) + + if self._input_major != self._schema_major: + # should never get here, the factory should handle this correctly! + msg = ('DEV_ERROR: version "{0}" parser received ' + 'version "{1}" input.'.format(known, received)) + fatal_error(msg) + + if self._input_minor > self._schema_minor: + msg = ('Incompatible schema version:\n' + ' User supplied schema version "{0}" is too new."\n' + ' Can only process version "{1}" files and ' + 'older.'.format(received, known)) + fatal_error(msg) + + if self._input_patch > self._schema_patch: + # NOTE(bja, 2018-03) ignoring for now... Not clear what + # conditions the test is needed. + pass + + def _check_user_input(self): + """Run a series of checks to attempt to validate the user input and + detect errors as soon as possible. + + NOTE(bja, 2018-03) These checks are called *after* the file is + read. That means the schema check can not occur here. + + Note: the order is important. check_optional will create + optional with null data. run check_data first to ensure + required data was provided correctly by the user. + + """ + self._check_data() + self._check_optional() + self._validate() + + def _check_data(self): + # pylint: disable=too-many-branches,too-many-statements + """Check user supplied data is valid where possible. + """ + for ext_name in self.keys(): + if (self[ext_name][self.REPO][self.PROTOCOL] + not in self.KNOWN_PRROTOCOLS): + msg = 'Unknown repository protocol "{0}" in "{1}".'.format( + self[ext_name][self.REPO][self.PROTOCOL], ext_name) + fatal_error(msg) + + if (self[ext_name][self.REPO][self.PROTOCOL] == + self.PROTOCOL_SVN): + if self.HASH in self[ext_name][self.REPO]: + msg = ('In repo description for "{0}". svn repositories ' + 'may not include the "hash" keyword.'.format( + ext_name)) + fatal_error(msg) + + if ((self[ext_name][self.REPO][self.PROTOCOL] != self.PROTOCOL_GIT) + and (self.SUBMODULE in self[ext_name])): + msg = ('self.SUBMODULE is only supported with {0} protocol, ' + '"{1}" is defined as an {2} repository') + fatal_error(msg.format(self.PROTOCOL_GIT, ext_name, + self[ext_name][self.REPO][self.PROTOCOL])) + + if (self[ext_name][self.REPO][self.PROTOCOL] != + self.PROTOCOL_EXTERNALS_ONLY): + ref_count = 0 + found_refs = '' + if self.TAG in self[ext_name][self.REPO]: + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.TAG, self[ext_name][self.REPO][self.TAG], + found_refs) + if self.BRANCH in self[ext_name][self.REPO]: + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.BRANCH, self[ext_name][self.REPO][self.BRANCH], + found_refs) + if self.HASH in self[ext_name][self.REPO]: + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.HASH, self[ext_name][self.REPO][self.HASH], + found_refs) + if (self.SUBMODULE in self[ext_name] and + self[ext_name][self.SUBMODULE]): + ref_count += 1 + found_refs = '"{0} = {1}", {2}'.format( + self.SUBMODULE, + self[ext_name][self.SUBMODULE], found_refs) + + if ref_count > 1: + msg = 'Model description is over specified! ' + if self.SUBMODULE in self[ext_name]: + msg += ('from_submodule is not compatible with ' + '"tag", "branch", or "hash" ') + else: + msg += (' Only one of "tag", "branch", or "hash" ' + 'may be specified ') + + msg += 'for repo description of "{0}".'.format(ext_name) + msg = '{0}\nFound: {1}'.format(msg, found_refs) + fatal_error(msg) + elif ref_count < 1: + msg = ('Model description is under specified! One of ' + '"tag", "branch", or "hash" must be specified for ' + 'repo description of "{0}"'.format(ext_name)) + fatal_error(msg) + + if (self.REPO_URL not in self[ext_name][self.REPO] and + (self.SUBMODULE not in self[ext_name] or + not self[ext_name][self.SUBMODULE])): + msg = ('Model description is under specified! Must have ' + '"repo_url" in repo ' + 'description for "{0}"'.format(ext_name)) + fatal_error(msg) + + if (self.SUBMODULE in self[ext_name] and + self[ext_name][self.SUBMODULE]): + if self.REPO_URL in self[ext_name][self.REPO]: + msg = ('Model description is over specified! ' + 'from_submodule keyword is not compatible ' + 'with {0} keyword for'.format(self.REPO_URL)) + msg = '{0} repo description of "{1}"'.format(msg, + ext_name) + fatal_error(msg) + + if self.PATH in self[ext_name]: + msg = ('Model description is over specified! ' + 'from_submodule keyword is not compatible with ' + '{0} keyword for'.format(self.PATH)) + msg = '{0} repo description of "{1}"'.format(msg, + ext_name) + fatal_error(msg) + + if self.REPO_URL in self[ext_name][self.REPO]: + url = expand_local_url( + self[ext_name][self.REPO][self.REPO_URL], ext_name) + self[ext_name][self.REPO][self.REPO_URL] = url + + def _check_optional(self): + # pylint: disable=too-many-branches + """Some fields like externals, repo:tag repo:branch are + (conditionally) optional. We don't want the user to be + required to enter them in every externals description file, but + still want to validate the input. Check conditions and add + default values if appropriate. + + """ + submod_desc = None # Only load submodules info once + for field in self: + # truely optional + if self.EXTERNALS not in self[field]: + self[field][self.EXTERNALS] = EMPTY_STR + + # git and svn repos must tags and branches for validation purposes. + if self.TAG not in self[field][self.REPO]: + self[field][self.REPO][self.TAG] = EMPTY_STR + if self.BRANCH not in self[field][self.REPO]: + self[field][self.REPO][self.BRANCH] = EMPTY_STR + if self.HASH not in self[field][self.REPO]: + self[field][self.REPO][self.HASH] = EMPTY_STR + if self.REPO_URL not in self[field][self.REPO]: + self[field][self.REPO][self.REPO_URL] = EMPTY_STR + if self.SPARSE not in self[field][self.REPO]: + self[field][self.REPO][self.SPARSE] = EMPTY_STR + + # from_submodule has a complex relationship with other fields + if self.SUBMODULE in self[field]: + # User wants to use submodule information, is it available? + if self._parent_repo is None: + # No parent == no submodule information + PPRINTER.pprint(self[field]) + msg = 'No parent submodule for "{0}"'.format(field) + fatal_error(msg) + elif self._parent_repo.protocol() != self.PROTOCOL_GIT: + PPRINTER.pprint(self[field]) + msg = 'Parent protocol, "{0}", does not support submodules' + fatal_error(msg.format(self._parent_repo.protocol())) + else: + args = self._repo_config_from_submodule(field, submod_desc) + repo_url, repo_path, ref_hash, submod_desc = args + + if repo_url is None: + msg = ('Cannot checkout "{0}" as a submodule, ' + 'repo not found in {1} file') + fatal_error(msg.format(field, + self.GIT_SUBMODULES_FILENAME)) + # Fill in submodule fields + self[field][self.REPO][self.REPO_URL] = repo_url + self[field][self.REPO][self.HASH] = ref_hash + self[field][self.PATH] = repo_path + + if self[field][self.SUBMODULE]: + # We should get everything from the parent submodule + # configuration. + pass + # No else (from _submodule = False is the default) + else: + # Add the default value (not using submodule information) + self[field][self.SUBMODULE] = False + + def _repo_config_from_submodule(self, field, submod_desc): + """Find the external config information for a repository from + its submodule configuration information. + """ + if submod_desc is None: + repo_path = os.getcwd() # Is this always correct? + submod_file = self._parent_repo.submodules_file(repo_path=repo_path) + if submod_file is None: + msg = ('Cannot checkout "{0}" from submodule information\n' + ' Parent repo, "{1}" does not have submodules') + fatal_error(msg.format(field, self._parent_repo.name())) + + printlog( + 'Processing submodules description file : {0} ({1})'.format( + submod_file, repo_path)) + submod_model_data= _read_gitmodules_file(repo_path, submod_file) + submod_desc = create_externals_description(submod_model_data) + + # Can we find our external? + repo_url = None + repo_path = None + ref_hash = None + for ext_field in submod_desc: + if field == ext_field: + ext = submod_desc[ext_field] + repo_url = ext[self.REPO][self.REPO_URL] + repo_path = ext[self.PATH] + ref_hash = ext[self.REPO][self.HASH] + break + + return repo_url, repo_path, ref_hash, submod_desc + + def _validate(self): + """Validate that the parsed externals description contains all necessary + fields. + + """ + def print_compare_difference(data_a, data_b, loc_a, loc_b): + """Look through the data structures and print the differences. + + """ + for item in data_a: + if item in data_b: + if not isinstance(data_b[item], type(data_a[item])): + printlog(" {item}: {loc} = {val} ({val_type})".format( + item=item, loc=loc_a, val=data_a[item], + val_type=type(data_a[item]))) + printlog(" {item} {loc} = {val} ({val_type})".format( + item=' ' * len(item), loc=loc_b, val=data_b[item], + val_type=type(data_b[item]))) + else: + printlog(" {item}: {loc} = {val} ({val_type})".format( + item=item, loc=loc_a, val=data_a[item], + val_type=type(data_a[item]))) + printlog(" {item} {loc} missing".format( + item=' ' * len(item), loc=loc_b)) + + def validate_data_struct(schema, data): + """Compare a data structure against a schema and validate all required + fields are present. + + """ + is_valid = False + in_ref = True + valid = True + if isinstance(schema, dict) and isinstance(data, dict): + # Both are dicts, recursively verify that all fields + # in schema are present in the data. + for key in schema: + in_ref = in_ref and (key in data) + if in_ref: + valid = valid and ( + validate_data_struct(schema[key], data[key])) + + is_valid = in_ref and valid + else: + # non-recursive structure. verify data and schema have + # the same type. + is_valid = isinstance(data, type(schema)) + + if not is_valid: + printlog(" Unmatched schema and input:") + if isinstance(schema, dict): + print_compare_difference(schema, data, 'schema', 'input') + print_compare_difference(data, schema, 'input', 'schema') + else: + printlog(" schema = {0} ({1})".format( + schema, type(schema))) + printlog(" input = {0} ({1})".format(data, type(data))) + + return is_valid + + for field in self: + valid = validate_data_struct(self._source_schema, self[field]) + if not valid: + PPRINTER.pprint(self._source_schema) + PPRINTER.pprint(self[field]) + msg = 'ERROR: source for "{0}" did not validate'.format(field) + fatal_error(msg) + + +class ExternalsDescriptionDict(ExternalsDescription): + """Create a externals description object from a dictionary using the API + representations. Primarily used to simplify creating model + description files for unit testing. + + """ + + def __init__(self, model_data, components=None, exclude=None): + """Parse a native dictionary into a externals description. + """ + ExternalsDescription.__init__(self) + self._schema_major = 1 + self._schema_minor = 0 + self._schema_patch = 0 + self._input_major = 1 + self._input_minor = 0 + self._input_patch = 0 + self._verify_schema_version() + if components: + for key in list(model_data.keys()): + if key not in components: + del model_data[key] + + if exclude: + for key in list(model_data.keys()): + if key in exclude: + del model_data[key] + + self.update(model_data) + self._check_user_input() + + +class ExternalsDescriptionConfigV1(ExternalsDescription): + """Create a externals description object from a config_parser object, + schema version 1. + + """ + + def __init__(self, model_data, components=None, exclude=None, parent_repo=None): + """Convert the config data into a standardized dict that can be used to + construct the source objects + + components: list of component names to include, None to include all. + exclude: list of component names to skip. + """ + ExternalsDescription.__init__(self, parent_repo=parent_repo) + self._schema_major = 1 + self._schema_minor = 1 + self._schema_patch = 0 + self._input_major, self._input_minor, self._input_patch = \ + get_cfg_schema_version(model_data) + self._verify_schema_version() + self._remove_metadata(model_data) + self._parse_cfg(model_data, components=components, exclude=exclude) + self._check_user_input() + + @staticmethod + def _remove_metadata(model_data): + """Remove the metadata section from the model configuration file so + that it is simpler to look through the file and construct the + externals description. + + """ + model_data.remove_section(DESCRIPTION_SECTION) + + def _parse_cfg(self, cfg_data, components=None, exclude=None): + """Parse a config_parser object into a externals description. + + components: list of component names to include, None to include all. + exclude: list of component names to skip. + """ + def list_to_dict(input_list, convert_to_lower_case=True): + """Convert a list of key-value pairs into a dictionary. + """ + output_dict = {} + for item in input_list: + key = config_string_cleaner(item[0].strip()) + value = config_string_cleaner(item[1].strip()) + if convert_to_lower_case: + key = key.lower() + output_dict[key] = value + return output_dict + + for section in cfg_data.sections(): + name = config_string_cleaner(section.lower().strip()) + if (components and name not in components) or (exclude and name in exclude): + continue + self[name] = {} + self[name].update(list_to_dict(cfg_data.items(section))) + self[name][self.REPO] = {} + loop_keys = self[name].copy().keys() + for item in loop_keys: + if item in self._source_schema: + if isinstance(self._source_schema[item], bool): + self[name][item] = str_to_bool(self[name][item]) + elif item in self._source_schema[self.REPO]: + self[name][self.REPO][item] = self[name][item] + del self[name][item] + else: + msg = ('Invalid input: "{sect}" contains unknown ' + 'item "{item}".'.format(sect=name, item=item)) + fatal_error(msg) diff --git a/src/core_atmosphere/tools/manage_externals/manic/externals_status.py b/src/core_atmosphere/tools/manage_externals/manic/externals_status.py new file mode 100644 index 0000000000..6bc29e9732 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/externals_status.py @@ -0,0 +1,164 @@ +"""ExternalStatus + +Class to store status and state information about repositories and +create a string representation. + +""" +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +from .global_constants import EMPTY_STR +from .utils import printlog, indent_string +from .global_constants import VERBOSITY_VERBOSE, VERBOSITY_DUMP + + +class ExternalStatus(object): + """Class to represent the status of a given source repository or tree. + + Individual repositories determine their own status in the + Repository objects. This object is just resposible for storing the + information and passing it up to a higher level for reporting or + global decisions. + + There are two states of concern: + + * If the repository is in-sync with the externals description file. + + * If the repostiory working copy is clean and there are no pending + transactions (e.g. add, remove, rename, untracked files). + + """ + # sync_state and clean_state can be one of the following: + DEFAULT = '-' # not set yet (sync_state). clean_state can be this if sync_state is EMPTY. + UNKNOWN = '?' + EMPTY = 'e' + MODEL_MODIFIED = 's' # repo version != externals (sync_state only) + DIRTY = 'M' # repo is dirty (clean_state only) + STATUS_OK = ' ' # repo is clean (clean_state) or matches externals version (sync_state) + STATUS_ERROR = '!' + + # source_type can be one of the following: + OPTIONAL = 'o' + STANDALONE = 's' + MANAGED = ' ' + + def __init__(self): + self.sync_state = self.DEFAULT + self.clean_state = self.DEFAULT + self.source_type = self.DEFAULT + self.path = EMPTY_STR + self.current_version = EMPTY_STR + self.expected_version = EMPTY_STR + self.status_output = EMPTY_STR + + def log_status_message(self, verbosity): + """Write status message to the screen and log file + """ + printlog(self._default_status_message()) + if verbosity >= VERBOSITY_VERBOSE: + printlog(self._verbose_status_message()) + if verbosity >= VERBOSITY_DUMP: + printlog(self._dump_status_message()) + + def __repr__(self): + return self._default_status_message() + + def _default_status_message(self): + """Return the default terse status message string + """ + return '{sync}{clean}{src_type} {path}'.format( + sync=self.sync_state, clean=self.clean_state, + src_type=self.source_type, path=self.path) + + def _verbose_status_message(self): + """Return the verbose status message string + """ + clean_str = self.DEFAULT + if self.clean_state == self.STATUS_OK: + clean_str = 'clean sandbox' + elif self.clean_state == self.DIRTY: + clean_str = 'modified sandbox' + + sync_str = 'on {0}'.format(self.current_version) + if self.sync_state != self.STATUS_OK: + sync_str = '{current} --> {expected}'.format( + current=self.current_version, expected=self.expected_version) + return ' {clean}, {sync}'.format(clean=clean_str, sync=sync_str) + + def _dump_status_message(self): + """Return the dump status message string + """ + return indent_string(self.status_output, 12) + + def safe_to_update(self): + """Report if it is safe to update a repository. Safe is defined as: + + * If a repository is empty, it is safe to update. + + * If a repository exists and has a clean working copy state + with no pending transactions. + + """ + safe_to_update = False + repo_exists = self.exists() + if not repo_exists: + safe_to_update = True + else: + # If the repo exists, it must be in ok or modified + # sync_state. Any other sync_state at this point + # represents a logic error that should have been handled + # before now! + sync_safe = ((self.sync_state == ExternalStatus.STATUS_OK) or + (self.sync_state == ExternalStatus.MODEL_MODIFIED)) + if sync_safe: + # The clean_state must be STATUS_OK to update. Otherwise we + # are dirty or there was a missed error previously. + if self.clean_state == ExternalStatus.STATUS_OK: + safe_to_update = True + return safe_to_update + + def exists(self): + """Determine if the repo exists. This is indicated by: + + * sync_state is not EMPTY + + * if the sync_state is empty, then the valid states for + clean_state are default, empty or unknown. Anything else + and there was probably an internal logic error. + + NOTE(bja, 2017-10) For the moment we are considering a + sync_state of default or unknown to require user intervention, + but we may want to relax this convention. This is probably a + result of a network error or internal logic error but more + testing is needed. + + """ + is_empty = (self.sync_state == ExternalStatus.EMPTY) + clean_valid = ((self.clean_state == ExternalStatus.DEFAULT) or + (self.clean_state == ExternalStatus.EMPTY) or + (self.clean_state == ExternalStatus.UNKNOWN)) + + if is_empty and clean_valid: + exists = False + else: + exists = True + return exists + + +def check_safe_to_update_repos(tree_status): + """Check if *ALL* repositories are in a safe state to update. We don't + want to do a partial update of the repositories then die, leaving + the model in an inconsistent state. + + Note: if there is an update to do, the repositories will by + definiation be out of synce with the externals description, so we + can't use that as criteria for updating. + + """ + safe_to_update = True + for comp in tree_status: + stat = tree_status[comp] + safe_to_update &= stat.safe_to_update() + + return safe_to_update diff --git a/src/core_atmosphere/tools/manage_externals/manic/global_constants.py b/src/core_atmosphere/tools/manage_externals/manic/global_constants.py new file mode 100644 index 0000000000..0e91cffc90 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/global_constants.py @@ -0,0 +1,18 @@ +"""Globals shared across modules +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import pprint + +EMPTY_STR = '' +LOCAL_PATH_INDICATOR = '.' +VERSION_SEPERATOR = '.' +LOG_FILE_NAME = 'manage_externals.log' +PPRINTER = pprint.PrettyPrinter(indent=4) + +VERBOSITY_DEFAULT = 0 +VERBOSITY_VERBOSE = 1 +VERBOSITY_DUMP = 2 diff --git a/src/core_atmosphere/tools/manage_externals/manic/repository.py b/src/core_atmosphere/tools/manage_externals/manic/repository.py new file mode 100644 index 0000000000..ea4230fb7b --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/repository.py @@ -0,0 +1,98 @@ +"""Base class representation of a repository +""" + +from .externals_description import ExternalsDescription +from .utils import fatal_error +from .global_constants import EMPTY_STR + + +class Repository(object): + """ + Class to represent and operate on a repository description. + """ + + def __init__(self, component_name, repo): + """ + Parse repo externals description + """ + self._name = component_name + self._protocol = repo[ExternalsDescription.PROTOCOL] + self._tag = repo[ExternalsDescription.TAG] + self._branch = repo[ExternalsDescription.BRANCH] + self._hash = repo[ExternalsDescription.HASH] + self._url = repo[ExternalsDescription.REPO_URL] + self._sparse = repo[ExternalsDescription.SPARSE] + + if self._url is EMPTY_STR: + fatal_error('repo must have a URL') + + if ((self._tag is EMPTY_STR) and (self._branch is EMPTY_STR) and + (self._hash is EMPTY_STR)): + fatal_error('{0} repo must have a branch, tag or hash element') + + ref_count = 0 + if self._tag is not EMPTY_STR: + ref_count += 1 + if self._branch is not EMPTY_STR: + ref_count += 1 + if self._hash is not EMPTY_STR: + ref_count += 1 + if ref_count != 1: + fatal_error('repo {0} must have exactly one of ' + 'tag, branch or hash.'.format(self._name)) + + def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): # pylint: disable=unused-argument + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly update the source. + If the repo destination directory does not exist, checkout the correce + branch or tag. + NB: is include as an argument for compatibility with + git functionality (repository_git.py) + """ + msg = ('DEV_ERROR: checkout method must be implemented in all ' + 'repository classes! {0}'.format(self.__class__.__name__)) + fatal_error(msg) + + def status(self, stat, repo_dir_path): # pylint: disable=unused-argument + """Report the status of the repo + + """ + msg = ('DEV_ERROR: status method must be implemented in all ' + 'repository classes! {0}'.format(self.__class__.__name__)) + fatal_error(msg) + + def submodules_file(self, repo_path=None): + # pylint: disable=no-self-use,unused-argument + """Stub for use by non-git VC systems""" + return None + + def url(self): + """Public access of repo url. + """ + return self._url + + def tag(self): + """Public access of repo tag + """ + return self._tag + + def branch(self): + """Public access of repo branch. + """ + return self._branch + + def hash(self): + """Public access of repo hash. + """ + return self._hash + + def name(self): + """Public access of repo name. + """ + return self._name + + def protocol(self): + """Public access of repo protocol. + """ + return self._protocol diff --git a/src/core_atmosphere/tools/manage_externals/manic/repository_factory.py b/src/core_atmosphere/tools/manage_externals/manic/repository_factory.py new file mode 100644 index 0000000000..18c73ffc4b --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/repository_factory.py @@ -0,0 +1,30 @@ +"""Factory for creating and initializing the appropriate repository class +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +from .repository_git import GitRepository +from .repository_svn import SvnRepository +from .externals_description import ExternalsDescription +from .utils import fatal_error + + +def create_repository(component_name, repo_info, svn_ignore_ancestry=False): + """Determine what type of repository we have, i.e. git or svn, and + create the appropriate object. + + Can return None (e.g. if protocol is 'externals_only'). + """ + protocol = repo_info[ExternalsDescription.PROTOCOL].lower() + if protocol == 'git': + repo = GitRepository(component_name, repo_info) + elif protocol == 'svn': + repo = SvnRepository(component_name, repo_info, ignore_ancestry=svn_ignore_ancestry) + elif protocol == 'externals_only': + repo = None + else: + msg = 'Unknown repo protocol "{0}"'.format(protocol) + fatal_error(msg) + return repo diff --git a/src/core_atmosphere/tools/manage_externals/manic/repository_git.py b/src/core_atmosphere/tools/manage_externals/manic/repository_git.py new file mode 100644 index 0000000000..aab1a468a8 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/repository_git.py @@ -0,0 +1,859 @@ +"""Class for interacting with git repositories +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import copy +import os +import sys + +from .global_constants import EMPTY_STR, LOCAL_PATH_INDICATOR +from .global_constants import VERBOSITY_VERBOSE +from .repository import Repository +from .externals_status import ExternalStatus +from .externals_description import ExternalsDescription, git_submodule_status +from .utils import expand_local_url, split_remote_url, is_remote_url +from .utils import fatal_error, printlog +from .utils import execute_subprocess + + +class GitRepository(Repository): + """Class to represent and operate on a repository description. + + For testing purpose, all system calls to git should: + + * be isolated in separate functions with no application logic + * of the form: + - cmd = 'git -C {dirname} ...'.format(dirname=dirname).split() + - value = execute_subprocess(cmd, output_to_caller={T|F}, + status_to_caller={T|F}) + - return value + * be static methods (not rely on self) + * name as _git_subcommand_args(user_args) + + This convention allows easy unit testing of the repository logic + by mocking the specific calls to return predefined results. + + """ + + def __init__(self, component_name, repo): + """ + repo: ExternalsDescription. + """ + Repository.__init__(self, component_name, repo) + self._gitmodules = None + self._submods = None + + # ---------------------------------------------------------------- + # + # Public API, defined by Repository + # + # ---------------------------------------------------------------- + def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly update the source. + If the repo destination directory does not exist, checkout the correct + branch or tag. + """ + repo_dir_path = os.path.join(base_dir_path, repo_dir_name) + repo_dir_exists = os.path.exists(repo_dir_path) + if (repo_dir_exists and not os.listdir( + repo_dir_path)) or not repo_dir_exists: + self._clone_repo(base_dir_path, repo_dir_name, verbosity) + self._checkout_ref(repo_dir_path, verbosity, recursive) + gmpath = os.path.join(repo_dir_path, + ExternalsDescription.GIT_SUBMODULES_FILENAME) + if os.path.exists(gmpath): + self._gitmodules = gmpath + self._submods = git_submodule_status(repo_dir_path) + else: + self._gitmodules = None + self._submods = None + + def status(self, stat, repo_dir_path): + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly update the source. + If the repo destination directory does not exist, checkout the correct + branch or tag. + """ + self._check_sync(stat, repo_dir_path) + if os.path.exists(repo_dir_path): + self._status_summary(stat, repo_dir_path) + + def submodules_file(self, repo_path=None): + if repo_path is not None: + gmpath = os.path.join(repo_path, + ExternalsDescription.GIT_SUBMODULES_FILENAME) + if os.path.exists(gmpath): + self._gitmodules = gmpath + self._submods = git_submodule_status(repo_path) + + return self._gitmodules + + # ---------------------------------------------------------------- + # + # Internal work functions + # + # ---------------------------------------------------------------- + def _clone_repo(self, base_dir_path, repo_dir_name, verbosity): + """Clones repo_dir_name into base_dir_path. + """ + self._git_clone(self._url, os.path.join(base_dir_path, repo_dir_name), + verbosity=verbosity) + + def _current_ref(self, dirname): + """Determine the *name* associated with HEAD at dirname. + + If we're on a tag, then returns the tag name; otherwise, returns + the current hash. Returns an empty string if no reference can be + determined (e.g., if we're not actually in a git repository). + + If we're on a branch, then the branch name is also included in + the returned string (in addition to the tag / hash). + """ + ref_found = False + + # If we're exactly at a tag, use that as the current ref + tag_found, tag_name = self._git_current_tag(dirname) + if tag_found: + current_ref = tag_name + ref_found = True + + if not ref_found: + # Otherwise, use current hash as the current ref + hash_found, hash_name = self._git_current_hash(dirname) + if hash_found: + current_ref = hash_name + ref_found = True + + if ref_found: + # If we're on a branch, include branch name in current ref + branch_found, branch_name = self._git_current_branch(dirname) + if branch_found: + current_ref = "{} (branch {})".format(current_ref, branch_name) + else: + # If we still can't find a ref, return empty string. This + # can happen if we're not actually in a git repo + current_ref = '' + + return current_ref + + def _check_sync(self, stat, repo_dir_path): + """Determine whether a git repository is in-sync with the model + description. + + Because repos can have multiple remotes, the only criteria is + whether the branch or tag is the same. + + """ + if not os.path.exists(repo_dir_path): + # NOTE(bja, 2017-10) condition should have been determined + # by _Source() object and should never be here! + stat.sync_state = ExternalStatus.STATUS_ERROR + else: + git_dir = os.path.join(repo_dir_path, '.git') + if not os.path.exists(git_dir): + # NOTE(bja, 2017-10) directory exists, but no git repo + # info.... Can't test with subprocess git command + # because git will move up directory tree until it + # finds the parent repo git dir! + stat.sync_state = ExternalStatus.UNKNOWN + else: + self._check_sync_logic(stat, repo_dir_path) + + def _check_sync_logic(self, stat, repo_dir_path): + """Compare the underlying hashes of the currently checkout ref and the + expected ref. + + Output: sets the sync_state as well as the current and + expected ref in the input status object. + + """ + def compare_refs(current_ref, expected_ref): + """Compare the current and expected ref. + + """ + if current_ref == expected_ref: + status = ExternalStatus.STATUS_OK + else: + status = ExternalStatus.MODEL_MODIFIED + return status + + # get the full hash of the current commit + _, current_ref = self._git_current_hash(repo_dir_path) + + if self._branch: + if self._url == LOCAL_PATH_INDICATOR: + expected_ref = self._branch + else: + remote_name = self._remote_name_for_url(self._url, + repo_dir_path) + if not remote_name: + # git doesn't know about this remote. by definition + # this is a modified state. + expected_ref = "unknown_remote/{0}".format(self._branch) + else: + expected_ref = "{0}/{1}".format(remote_name, self._branch) + elif self._hash: + expected_ref = self._hash + elif self._tag: + expected_ref = self._tag + else: + msg = 'In repo "{0}": none of branch, hash or tag are set'.format( + self._name) + fatal_error(msg) + + # record the *names* of the current and expected branches + stat.current_version = self._current_ref(repo_dir_path) + stat.expected_version = copy.deepcopy(expected_ref) + + if current_ref == EMPTY_STR: + stat.sync_state = ExternalStatus.UNKNOWN + else: + # get the underlying hash of the expected ref + revparse_status, expected_ref_hash = self._git_revparse_commit( + expected_ref, repo_dir_path) + if revparse_status: + # We failed to get the hash associated with + # expected_ref. Maybe we should assign this to some special + # status, but for now we're just calling this out-of-sync to + # remain consistent with how this worked before. + stat.sync_state = ExternalStatus.MODEL_MODIFIED + else: + # compare the underlying hashes + stat.sync_state = compare_refs(current_ref, expected_ref_hash) + + @classmethod + def _remote_name_for_url(cls, remote_url, dirname): + """Return the remote name matching remote_url (or None) + + """ + git_output = cls._git_remote_verbose(dirname) + git_output = git_output.splitlines() + for line in git_output: + data = line.strip() + if not data: + continue + data = data.split() + name = data[0].strip() + url = data[1].strip() + if remote_url == url: + return name + return None + + def _create_remote_name(self): + """The url specified in the externals description file was not known + to git. We need to add it, which means adding a unique and + safe name.... + + The assigned name needs to be safe for git to use, e.g. can't + look like a path 'foo/bar' and work with both remote and local paths. + + Remote paths include but are not limited to: git, ssh, https, + github, gitlab, bitbucket, custom server, etc. + + Local paths can be relative or absolute. They may contain + shell variables, e.g. ${REPO_ROOT}/repo_name, or username + expansion, i.e. ~/ or ~someuser/. + + Relative paths must be at least one layer of redirection, i.e. + container/../ext_repo, but may be many layers deep, e.g. + container/../../../../../ext_repo + + NOTE(bja, 2017-11) + + The base name below may not be unique, for example if the + user has local paths like: + + /path/to/my/repos/nice_repo + /path/to/other/repos/nice_repo + + But the current implementation should cover most common + use cases for remotes and still provide usable names. + + """ + url = copy.deepcopy(self._url) + if is_remote_url(url): + url = split_remote_url(url) + else: + url = expand_local_url(url, self._name) + url = url.split('/') + repo_name = url[-1] + base_name = url[-2] + # repo name should nominally already be something that git can + # deal with. We need to remove other possibly troublesome + # punctuation, e.g. /, $, from the base name. + unsafe_characters = '!@#$%^&*()[]{}\\/,;~' + for unsafe in unsafe_characters: + base_name = base_name.replace(unsafe, '') + remote_name = "{0}_{1}".format(base_name, repo_name) + return remote_name + + def _checkout_ref(self, repo_dir, verbosity, submodules): + """Checkout the user supplied reference + if is True, recursively initialize and update + the repo's submodules + """ + # import pdb; pdb.set_trace() + if self._url.strip() == LOCAL_PATH_INDICATOR: + self._checkout_local_ref(verbosity, submodules, repo_dir) + else: + self._checkout_external_ref(verbosity, submodules, repo_dir) + + if self._sparse: + self._sparse_checkout(repo_dir, verbosity) + + + def _checkout_local_ref(self, verbosity, submodules, dirname): + """Checkout the reference considering the local repo only. Do not + fetch any additional remotes or specify the remote when + checkout out the ref. + if is True, recursively initialize and update + the repo's submodules + """ + if self._tag: + ref = self._tag + elif self._branch: + ref = self._branch + else: + ref = self._hash + + self._check_for_valid_ref(ref, remote_name=None, + dirname=dirname) + self._git_checkout_ref(ref, verbosity, submodules, dirname) + + def _checkout_external_ref(self, verbosity, submodules, dirname): + """Checkout the reference from a remote repository into dirname. + if is True, recursively initialize and update + the repo's submodules. + Note that this results in a 'detached HEAD' state if checking out + a branch, because we check out the remote branch rather than the + local. See https://github.com/ESMCI/manage_externals/issues/34 for + more discussion. + """ + if self._tag: + ref = self._tag + elif self._branch: + ref = self._branch + else: + ref = self._hash + + remote_name = self._remote_name_for_url(self._url, dirname) + if not remote_name: + remote_name = self._create_remote_name() + self._git_remote_add(remote_name, self._url, dirname) + self._git_fetch(remote_name, dirname) + + # NOTE(bja, 2018-03) we need to send separate ref and remote + # name to check_for_vaild_ref, but the combined name to + # checkout_ref! + self._check_for_valid_ref(ref, remote_name, dirname) + + if self._branch: + # Prepend remote name to branch. This means we avoid various + # special cases if the local branch is not tracking the remote or + # cannot be trivially fast-forwarded to match; but, it also + # means we end up in a 'detached HEAD' state. + ref = '{0}/{1}'.format(remote_name, ref) + self._git_checkout_ref(ref, verbosity, submodules, dirname) + + def _sparse_checkout(self, repo_dir, verbosity): + """Use git read-tree to thin the working tree.""" + cmd = ['cp', os.path.join(repo_dir, self._sparse), + os.path.join(repo_dir, + '.git/info/sparse-checkout')] + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + self._git_sparse_checkout(verbosity, repo_dir) + + def _check_for_valid_ref(self, ref, remote_name, dirname): + """Try some basic sanity checks on the user supplied reference so we + can provide a more useful error message than calledprocess + error... + + remote_name can be NOne + """ + is_tag = self._ref_is_tag(ref, dirname) + is_branch = self._ref_is_branch(ref, remote_name, dirname) + is_hash = self._ref_is_hash(ref, dirname) + is_valid = is_tag or is_branch or is_hash + if not is_valid: + msg = ('In repo "{0}": reference "{1}" does not appear to be a ' + 'valid tag, branch or hash! Please verify the reference ' + 'name (e.g. spelling), is available from: {2} '.format( + self._name, ref, self._url)) + fatal_error(msg) + + if is_tag: + is_unique_tag, msg = self._is_unique_tag(ref, remote_name, + dirname) + if not is_unique_tag: + msg = ('In repo "{0}": tag "{1}" {2}'.format( + self._name, self._tag, msg)) + fatal_error(msg) + + return is_valid + + def _is_unique_tag(self, ref, remote_name, dirname): + """Verify that a reference is a valid tag and is unique (not a branch) + + Tags may be tag names, or SHA id's. It is also possible that a + branch and tag have the some name. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_tag = self._ref_is_tag(ref, dirname) + is_branch = self._ref_is_branch(ref, remote_name, dirname) + is_hash = self._ref_is_hash(ref, dirname) + + msg = '' + is_unique_tag = False + if is_tag and not is_branch: + # unique tag + msg = 'is ok' + is_unique_tag = True + elif is_tag and is_branch: + msg = ('is both a branch and a tag. git may checkout the branch ' + 'instead of the tag depending on your version of git.') + is_unique_tag = False + elif not is_tag and is_branch: + msg = ('is a branch, and not a tag. If you intended to checkout ' + 'a branch, please change the externals description to be ' + 'a branch. If you intended to checkout a tag, it does not ' + 'exist. Please check the name.') + is_unique_tag = False + else: # not is_tag and not is_branch: + if is_hash: + # probably a sha1 or HEAD, etc, we call it a tag + msg = 'is ok' + is_unique_tag = True + else: + # undetermined state. + msg = ('does not appear to be a valid tag, branch or hash! ' + 'Please check the name and repository.') + is_unique_tag = False + + return is_unique_tag, msg + + def _ref_is_tag(self, ref, dirname): + """Verify that a reference is a valid tag according to git. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + """ + is_tag = False + value = self._git_showref_tag(ref, dirname) + if value == 0: + is_tag = True + return is_tag + + def _ref_is_branch(self, ref, remote_name, dirname): + """Verify if a ref is any kind of branch (local, tracked remote, + untracked remote). + + remote_name can be None. + """ + local_branch = False + remote_branch = False + if remote_name: + remote_branch = self._ref_is_remote_branch(ref, remote_name, + dirname) + local_branch = self._ref_is_local_branch(ref, dirname) + + is_branch = False + if local_branch or remote_branch: + is_branch = True + return is_branch + + def _ref_is_local_branch(self, ref, dirname): + """Verify that a reference is a valid branch according to git. + + show-ref branch returns local branches that have been + previously checked out. It will not necessarily pick up + untracked remote branches. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_branch = False + value = self._git_showref_branch(ref, dirname) + if value == 0: + is_branch = True + return is_branch + + def _ref_is_remote_branch(self, ref, remote_name, dirname): + """Verify that a reference is a valid branch according to git. + + show-ref branch returns local branches that have been + previously checked out. It will not necessarily pick up + untracked remote branches. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_branch = False + value = self._git_lsremote_branch(ref, remote_name, dirname) + if value == 0: + is_branch = True + return is_branch + + def _ref_is_commit(self, ref, dirname): + """Verify that a reference is a valid commit according to git. + + This could be a tag, branch, sha1 id, HEAD and potentially others... + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + """ + is_commit = False + value, _ = self._git_revparse_commit(ref, dirname) + if value == 0: + is_commit = True + return is_commit + + def _ref_is_hash(self, ref, dirname): + """Verify that a reference is a valid hash according to git. + + Git doesn't seem to provide an exact way to determine if user + supplied reference is an actual hash. So we verify that the + ref is a valid commit and return the underlying commit + hash. Then check that the commit hash begins with the user + supplied string. + + Note: values returned by git_showref_* and git_revparse are + shell return codes, which are zero for success, non-zero for + error! + + """ + is_hash = False + status, git_output = self._git_revparse_commit(ref, dirname) + if status == 0: + if git_output.strip().startswith(ref): + is_hash = True + return is_hash + + def _status_summary(self, stat, repo_dir_path): + """Determine the clean/dirty status of a git repository + + """ + git_output = self._git_status_porcelain_v1z(repo_dir_path) + is_dirty = self._status_v1z_is_dirty(git_output) + if is_dirty: + stat.clean_state = ExternalStatus.DIRTY + else: + stat.clean_state = ExternalStatus.STATUS_OK + + # Now save the verbose status output incase the user wants to + # see it. + stat.status_output = self._git_status_verbose(repo_dir_path) + + @staticmethod + def _status_v1z_is_dirty(git_output): + """Parse the git status output from --porcelain=v1 -z and determine if + the repo status is clean or dirty. Dirty means: + + * modified files + * missing files + * added files + * removed + * renamed + * unmerged + + Whether untracked files are considered depends on how the status + command was run (i.e., whether it was run with the '-u' option). + + NOTE: Based on the above definition, the porcelain status + should be an empty string to be considered 'clean'. Of course + this assumes we only get an empty string from an status + command on a clean checkout, and not some error + condition... Could alse use 'git diff --quiet'. + + """ + is_dirty = False + if git_output: + is_dirty = True + return is_dirty + + # ---------------------------------------------------------------- + # + # system call to git for information gathering + # + # ---------------------------------------------------------------- + @staticmethod + def _git_current_hash(dirname): + """Return the full hash of the currently checked-out version. + + Returns a tuple, (hash_found, hash), where hash_found is a + logical specifying whether a hash was found for HEAD (False + could mean we're not in a git repository at all). (If hash_found + is False, then hash is ''.) + """ + status, git_output = GitRepository._git_revparse_commit("HEAD", + dirname) + hash_found = not status + if not hash_found: + git_output = '' + return hash_found, git_output + + @staticmethod + def _git_current_remote_branch(dirname): + """Determines the name of the current remote branch, if any. + + if dir is None, uses the cwd. + + Returns a tuple, (branch_found, branch_name), where branch_found + is a bool specifying whether a branch name was found for + HEAD. (If branch_found is False, then branch_name is ''). + branch_name is in the format '$remote/$branch', e.g. 'origin/foo'. + """ + branch_found = False + branch_name = '' + + cmd = 'git -C {dirname} log -n 1 --pretty=%d HEAD'.format( + dirname=dirname).split() + status, git_output = execute_subprocess(cmd, + output_to_caller=True, + status_to_caller=True) + branch_found = 'HEAD,' in git_output + if branch_found: + # git_output is of the form " (HEAD, origin/blah)" + branch_name = git_output.split(',')[1].strip()[:-1] + return branch_found, branch_name + + @staticmethod + def _git_current_branch(dirname): + """Determines the name of the current local branch. + + Returns a tuple, (branch_found, branch_name), where branch_found + is a bool specifying whether a branch name was found for + HEAD. (If branch_found is False, then branch_name is ''.) + Note that currently we check out the remote branch rather than + the local, so this command does not return the just-checked-out + branch. See _git_current_remote_branch. + """ + cmd = 'git -C {dirname} symbolic-ref --short -q HEAD'.format( + dirname=dirname).split() + status, git_output = execute_subprocess(cmd, + output_to_caller=True, + status_to_caller=True) + branch_found = not status + if branch_found: + git_output = git_output.strip() + else: + git_output = '' + return branch_found, git_output + + @staticmethod + def _git_current_tag(dirname): + """Determines the name tag corresponding to HEAD (if any). + + if dirname is None, uses the cwd. + + Returns a tuple, (tag_found, tag_name), where tag_found is a + bool specifying whether we found a tag name corresponding to + HEAD. (If tag_found is False, then tag_name is ''.) + """ + cmd = 'git -C {dirname} describe --exact-match --tags HEAD'.format( + dirname=dirname).split() + status, git_output = execute_subprocess(cmd, + output_to_caller=True, + status_to_caller=True) + tag_found = not status + if tag_found: + git_output = git_output.strip() + else: + git_output = '' + return tag_found, git_output + + @staticmethod + def _git_showref_tag(ref, dirname): + """Run git show-ref check if the user supplied ref is a tag. + + could also use git rev-parse --quiet --verify tagname^{tag} + """ + cmd = ('git -C {dirname} show-ref --quiet --verify refs/tags/{ref}' + .format(dirname=dirname, ref=ref).split()) + status = execute_subprocess(cmd, status_to_caller=True) + return status + + @staticmethod + def _git_showref_branch(ref, dirname): + """Run git show-ref check if the user supplied ref is a local or + tracked remote branch. + + """ + cmd = ('git -C {dirname} show-ref --quiet --verify refs/heads/{ref}' + .format(dirname=dirname, ref=ref).split()) + status = execute_subprocess(cmd, status_to_caller=True) + return status + + @staticmethod + def _git_lsremote_branch(ref, remote_name, dirname): + """Run git ls-remote to check if the user supplied ref is a remote + branch that is not being tracked + + """ + cmd = ('git -C {dirname} ls-remote --exit-code --heads ' + '{remote_name} {ref}').format( + dirname=dirname, remote_name=remote_name, ref=ref).split() + status, output = execute_subprocess(cmd, status_to_caller=True, output_to_caller=True) + if not status and not f"refs/heads/{ref}" in output: + # In this case the ref is contained in the branch name but is not the complete branch name + return -1 + return status + + @staticmethod + def _git_revparse_commit(ref, dirname): + """Run git rev-parse to detect if a reference is a SHA, HEAD or other + valid commit. + + """ + cmd = ('git -C {dirname} rev-parse --quiet --verify {ref}^{commit}' + .format(dirname=dirname, ref=ref, commit='{commit}').split()) + status, git_output = execute_subprocess(cmd, status_to_caller=True, + output_to_caller=True) + git_output = git_output.strip() + return status, git_output + + @staticmethod + def _git_status_porcelain_v1z(dirname): + """Run git status to obtain repository information. + + This is run with '--untracked=no' to ignore untracked files. + + The machine-portable format that is guaranteed not to change + between git versions or *user configuration*. + + """ + cmd = ('git -C {dirname} status --untracked-files=no --porcelain -z' + .format(dirname=dirname)).split() + git_output = execute_subprocess(cmd, output_to_caller=True) + return git_output + + @staticmethod + def _git_status_verbose(dirname): + """Run the git status command to obtain repository information. + """ + cmd = 'git -C {dirname} status'.format(dirname=dirname).split() + git_output = execute_subprocess(cmd, output_to_caller=True) + return git_output + + @staticmethod + def _git_remote_verbose(dirname): + """Run the git remote command to obtain repository information. + + Returned string is of the form: + myfork git@github.com:johnpaulalex/manage_externals_jp.git (fetch) + myfork git@github.com:johnpaulalex/manage_externals_jp.git (push) + """ + cmd = 'git -C {dirname} remote --verbose'.format( + dirname=dirname).split() + return execute_subprocess(cmd, output_to_caller=True) + + @staticmethod + def has_submodules(repo_dir_path): + """Return True iff the repository at has a + '.gitmodules' file + """ + fname = os.path.join(repo_dir_path, + ExternalsDescription.GIT_SUBMODULES_FILENAME) + + return os.path.exists(fname) + + # ---------------------------------------------------------------- + # + # system call to git for sideffects modifying the working tree + # + # ---------------------------------------------------------------- + @staticmethod + def _git_clone(url, repo_dir_name, verbosity): + """Clones url into repo_dir_name. + """ + cmd = 'git clone --quiet {url} {repo_dir_name}'.format( + url=url, repo_dir_name=repo_dir_name).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + + @staticmethod + def _git_remote_add(name, url, dirname): + """Run the git remote command for the side effect of adding a remote + """ + cmd = 'git -C {dirname} remote add {name} {url}'.format( + dirname=dirname, name=name, url=url).split() + execute_subprocess(cmd) + + @staticmethod + def _git_fetch(remote_name, dirname): + """Run the git fetch command for the side effect of updating the repo + """ + cmd = 'git -C {dirname} fetch --quiet --tags {remote_name}'.format( + dirname=dirname, remote_name=remote_name).split() + execute_subprocess(cmd) + + @staticmethod + def _git_checkout_ref(ref, verbosity, submodules, dirname): + """Run the git checkout command for the side effect of updating the repo + + Param: ref is a reference to a local or remote object in the + form 'origin/my_feature', or 'tag1'. + + """ + cmd = 'git -C {dirname} checkout --quiet {ref}'.format( + dirname=dirname, ref=ref).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + if submodules: + GitRepository._git_update_submodules(verbosity, dirname) + + @staticmethod + def _git_sparse_checkout(verbosity, dirname): + """Configure repo via read-tree.""" + cmd = 'git -C {dirname} config core.sparsecheckout true'.format( + dirname=dirname).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + cmd = 'git -C {dirname} read-tree -mu HEAD'.format( + dirname=dirname).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + + @staticmethod + def _git_update_submodules(verbosity, dirname): + """Run git submodule update for the side effect of updating this + repo's submodules. + """ + # due to https://vielmetti.typepad.com/logbook/2022/10/git-security-fixes-lead-to-fatal-transport-file-not-allowed-error-in-ci-systems-cve-2022-39253.html + # submodules from file doesn't work without overriding the protocol, this is done + # for testing submodule support but should not be done in practice + file_protocol = "" + if 'unittest' in sys.modules.keys(): + file_protocol = "-c protocol.file.allow=always" + + # First, verify that we have a .gitmodules file + if os.path.exists( + os.path.join(dirname, + ExternalsDescription.GIT_SUBMODULES_FILENAME)): + cmd = ('git {file_protocol} -C {dirname} submodule update --init --recursive' + .format(file_protocol=file_protocol, dirname=dirname)).split() + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + + execute_subprocess(cmd) diff --git a/src/core_atmosphere/tools/manage_externals/manic/repository_svn.py b/src/core_atmosphere/tools/manage_externals/manic/repository_svn.py new file mode 100644 index 0000000000..b66c72e079 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/repository_svn.py @@ -0,0 +1,291 @@ +"""Class for interacting with svn repositories +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import os +import re +import xml.etree.ElementTree as ET + +from .global_constants import EMPTY_STR, VERBOSITY_VERBOSE +from .repository import Repository +from .externals_status import ExternalStatus +from .utils import fatal_error, indent_string, printlog +from .utils import execute_subprocess + + +class SvnRepository(Repository): + """ + Class to represent and operate on a repository description. + + For testing purpose, all system calls to svn should: + + * be isolated in separate functions with no application logic + * of the form: + - cmd = ['svn', ...] + - value = execute_subprocess(cmd, output_to_caller={T|F}, + status_to_caller={T|F}) + - return value + * be static methods (not rely on self) + * name as _svn_subcommand_args(user_args) + + This convention allows easy unit testing of the repository logic + by mocking the specific calls to return predefined results. + + """ + RE_URLLINE = re.compile(r'^URL:') + + def __init__(self, component_name, repo, ignore_ancestry=False): + """ + Parse repo (a XML element). + """ + Repository.__init__(self, component_name, repo) + self._ignore_ancestry = ignore_ancestry + if self._url.endswith('/'): + # there is already a '/' separator in the URL; no need to add another + url_sep = '' + else: + url_sep = '/' + if self._branch: + self._url = self._url + url_sep + self._branch + elif self._tag: + self._url = self._url + url_sep + self._tag + else: + msg = "DEV_ERROR in svn repository. Shouldn't be here!" + fatal_error(msg) + + # ---------------------------------------------------------------- + # + # Public API, defined by Repository + # + # ---------------------------------------------------------------- + def checkout(self, base_dir_path, repo_dir_name, verbosity, recursive): # pylint: disable=unused-argument + """Checkout or update the working copy + + If the repo destination directory exists, switch the sandbox to + match the externals description. + + If the repo destination directory does not exist, checkout the + correct branch or tag. + NB: is include as an argument for compatibility with + git functionality (repository_git.py) + + """ + repo_dir_path = os.path.join(base_dir_path, repo_dir_name) + if 'github.com' in self._url: + msg = "SVN access to github.com is no longer supported" + fatal_error(msg) + if os.path.exists(repo_dir_path): + cwd = os.getcwd() + os.chdir(repo_dir_path) + self._svn_switch(self._url, self._ignore_ancestry, verbosity) + # svn switch can lead to a conflict state, but it gives a + # return code of 0. So now we need to make sure that we're + # in a clean (non-conflict) state. + self._abort_if_dirty(repo_dir_path, + "Expected clean state following switch") + os.chdir(cwd) + else: + self._svn_checkout(self._url, repo_dir_path, verbosity) + + def status(self, stat, repo_dir_path): + """ + Check and report the status of the repository + """ + self._check_sync(stat, repo_dir_path) + if os.path.exists(repo_dir_path): + self._status_summary(stat, repo_dir_path) + + # ---------------------------------------------------------------- + # + # Internal work functions + # + # ---------------------------------------------------------------- + def _check_sync(self, stat, repo_dir_path): + """Check to see if repository directory exists and is at the expected + url. Return: status object + + """ + if not os.path.exists(repo_dir_path): + # NOTE(bja, 2017-10) this state should have been handled by + # the source object and we never get here! + stat.sync_state = ExternalStatus.STATUS_ERROR + else: + svn_output = self._svn_info(repo_dir_path) + if not svn_output: + # directory exists, but info returned nothing. .svn + # directory removed or incomplete checkout? + stat.sync_state = ExternalStatus.UNKNOWN + else: + stat.sync_state, stat.current_version = \ + self._check_url(svn_output, self._url) + stat.expected_version = '/'.join(self._url.split('/')[3:]) + + def _abort_if_dirty(self, repo_dir_path, message): + """Check if the repo is in a dirty state; if so, abort with a + helpful message. + + """ + + stat = ExternalStatus() + self._status_summary(stat, repo_dir_path) + if stat.clean_state != ExternalStatus.STATUS_OK: + status = self._svn_status_verbose(repo_dir_path) + status = indent_string(status, 4) + errmsg = """In directory + {cwd} + +svn status now shows: +{status} + +ERROR: {message} + +One possible cause of this problem is that there may have been untracked +files in your working directory that had the same name as tracked files +in the new revision. + +To recover: Clean up the above directory (resolving conflicts, etc.), +then rerun checkout_externals. +""".format(cwd=repo_dir_path, message=message, status=status) + + fatal_error(errmsg) + + @staticmethod + def _check_url(svn_output, expected_url): + """Determine the svn url from svn info output and return whether it + matches the expected value. + + """ + url = None + for line in svn_output.splitlines(): + if SvnRepository.RE_URLLINE.match(line): + url = line.split(': ')[1].strip() + break + if not url: + status = ExternalStatus.UNKNOWN + elif url == expected_url: + status = ExternalStatus.STATUS_OK + else: + status = ExternalStatus.MODEL_MODIFIED + + if url: + current_version = '/'.join(url.split('/')[3:]) + else: + current_version = EMPTY_STR + + return status, current_version + + def _status_summary(self, stat, repo_dir_path): + """Report whether the svn repository is in-sync with the model + description and whether the sandbox is clean or dirty. + + """ + svn_output = self._svn_status_xml(repo_dir_path) + is_dirty = self.xml_status_is_dirty(svn_output) + if is_dirty: + stat.clean_state = ExternalStatus.DIRTY + else: + stat.clean_state = ExternalStatus.STATUS_OK + + # Now save the verbose status output incase the user wants to + # see it. + stat.status_output = self._svn_status_verbose(repo_dir_path) + + @staticmethod + def xml_status_is_dirty(svn_output): + """Parse svn status xml output and determine if the working copy is + clean or dirty. Dirty is defined as: + + * modified files + * added files + * deleted files + * missing files + + Unversioned files do not affect the clean/dirty status. + + 'external' is also an acceptable state + + """ + # pylint: disable=invalid-name + SVN_EXTERNAL = 'external' + SVN_UNVERSIONED = 'unversioned' + # pylint: enable=invalid-name + + is_dirty = False + try: + xml_status = ET.fromstring(svn_output) + except BaseException: + fatal_error( + "SVN returned invalid XML message {}".format(svn_output)) + xml_target = xml_status.find('./target') + entries = xml_target.findall('./entry') + for entry in entries: + status = entry.find('./wc-status') + item = status.get('item') + if item == SVN_EXTERNAL: + continue + if item == SVN_UNVERSIONED: + continue + is_dirty = True + break + return is_dirty + + # ---------------------------------------------------------------- + # + # system call to svn for information gathering + # + # ---------------------------------------------------------------- + @staticmethod + def _svn_info(repo_dir_path): + """Return results of svn info command + """ + cmd = ['svn', 'info', repo_dir_path] + output = execute_subprocess(cmd, output_to_caller=True) + return output + + @staticmethod + def _svn_status_verbose(repo_dir_path): + """capture the full svn status output + """ + cmd = ['svn', 'status', repo_dir_path] + svn_output = execute_subprocess(cmd, output_to_caller=True) + return svn_output + + @staticmethod + def _svn_status_xml(repo_dir_path): + """ + Get status of the subversion sandbox in repo_dir + """ + cmd = ['svn', 'status', '--xml', repo_dir_path] + svn_output = execute_subprocess(cmd, output_to_caller=True) + return svn_output + + # ---------------------------------------------------------------- + # + # system call to svn for sideffects modifying the working tree + # + # ---------------------------------------------------------------- + @staticmethod + def _svn_checkout(url, repo_dir_path, verbosity): + """ + Checkout a subversion repository (repo_url) to checkout_dir. + """ + cmd = ['svn', 'checkout', '--quiet', url, repo_dir_path] + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) + + @staticmethod + def _svn_switch(url, ignore_ancestry, verbosity): + """ + Switch branches for in an svn sandbox + """ + cmd = ['svn', 'switch', '--quiet'] + if ignore_ancestry: + cmd.append('--ignore-ancestry') + cmd.append(url) + if verbosity >= VERBOSITY_VERBOSE: + printlog(' {0}'.format(' '.join(cmd))) + execute_subprocess(cmd) diff --git a/src/core_atmosphere/tools/manage_externals/manic/sourcetree.py b/src/core_atmosphere/tools/manage_externals/manic/sourcetree.py new file mode 100644 index 0000000000..cf2a5b7569 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/sourcetree.py @@ -0,0 +1,425 @@ +""" +Classes to represent an externals config file (SourceTree) and the components +within it (_External). +""" + +import errno +import logging +import os + +from .externals_description import ExternalsDescription +from .externals_description import read_externals_description_file +from .externals_description import create_externals_description +from .repository_factory import create_repository +from .repository_git import GitRepository +from .externals_status import ExternalStatus +from .utils import fatal_error, printlog +from .global_constants import EMPTY_STR, LOCAL_PATH_INDICATOR +from .global_constants import VERBOSITY_VERBOSE + +class _External(object): + """ + A single component hosted in an external repository (and any children). + + The component may or may not be checked-out upon construction. + """ + # pylint: disable=R0902 + + def __init__(self, root_dir, name, local_path, required, subexternals_path, + repo, svn_ignore_ancestry, subexternal_sourcetree): + """Create a single external component (checked out or not). + + Input: + root_dir : string - the (checked-out) parent repo's root dir. + local_path : string - this external's (checked-out) subdir relative + to root_dir, e.g. "components/mom" + repo: Repository - the repo object for this external. Can be None (e.g. if this external just refers to another external file). + + name : string - name of this external (as named by the parent + reference). May or may not correspond to something in the path. + + ext_description : dict - source ExternalsDescription object + + svn_ignore_ancestry : bool - use --ignore-externals with svn switch + + subexternals_path: string - path to sub-externals config file, if any. Relative to local_path, or special value 'none'. + subexternal_sourcetree: SourceTree - corresponding to subexternals_path, if subexternals_path exists (it might not, if it is not checked out yet). + """ + self._name = name + self._required = required + + self._stat = None # Populated in status() + + self._local_path = local_path + # _repo_dir_path : full repository directory, e.g. + # "/components/mom" + repo_dir = os.path.join(root_dir, local_path) + self._repo_dir_path = os.path.abspath(repo_dir) + # _base_dir_path : base directory *containing* the repository, e.g. + # "/components" + self._base_dir_path = os.path.dirname(self._repo_dir_path) + # _repo_dir_name : base_dir_path + repo_dir_name = repo_dir_path + # e.g., "mom" + self._repo_dir_name = os.path.basename(self._repo_dir_path) + self._repo = repo + + # Does this component have subcomponents aka an externals config? + self._subexternals_path = subexternals_path + self._subexternal_sourcetree = subexternal_sourcetree + + + def get_name(self): + """ + Return the external object's name + """ + return self._name + + def get_local_path(self): + """ + Return the external object's path + """ + return self._local_path + + def get_repo_dir_path(self): + return self._repo_dir_path + + def get_subexternals_path(self): + return self._subexternals_path + + def get_repo(self): + return self._repo + + def status(self, force=False, print_progress=False): + """ + Returns status of this component and all subcomponents. + + Returns a dict mapping our local path (not component name!) to an + ExternalStatus dict. Any subcomponents will have their own top-level + path keys. Note the return value includes entries for this and all + subcomponents regardless of whether they are locally installed or not. + + Side-effect: If self._stat is empty or force is True, calculates _stat. + """ + calc_stat = force or not self._stat + + if calc_stat: + self._stat = ExternalStatus() + self._stat.path = self.get_local_path() + if not self._required: + self._stat.source_type = ExternalStatus.OPTIONAL + elif self._local_path == LOCAL_PATH_INDICATOR: + # LOCAL_PATH_INDICATOR, '.' paths, are standalone + # component directories that are not managed by + # checkout_subexternals. + self._stat.source_type = ExternalStatus.STANDALONE + else: + # managed by checkout_subexternals + self._stat.source_type = ExternalStatus.MANAGED + + subcomponent_stats = {} + if not os.path.exists(self._repo_dir_path): + if calc_stat: + # No local repository. + self._stat.sync_state = ExternalStatus.EMPTY + msg = ('status check: repository directory for "{0}" does not ' + 'exist.'.format(self._name)) + logging.info(msg) + self._stat.current_version = 'not checked out' + # NOTE(bja, 2018-01) directory doesn't exist, so we cannot + # use repo to determine the expected version. We just take + # a best-guess based on the assumption that only tag or + # branch should be set, but not both. + if not self._repo: + self._stat.expected_version = 'unknown' + else: + self._stat.expected_version = self._repo.tag() + self._repo.branch() + else: + # Merge local repository state (e.g. clean/dirty) into self._stat. + if calc_stat and self._repo: + self._repo.status(self._stat, self._repo_dir_path) + + # Status of subcomponents, if any. + if self._subexternals_path and self._subexternal_sourcetree: + cwd = os.getcwd() + # SourceTree.status() expects to be called from the correct + # root directory. + os.chdir(self._repo_dir_path) + subcomponent_stats = self._subexternal_sourcetree.status(self._local_path, force=force, print_progress=print_progress) + os.chdir(cwd) + + # Merge our status + subcomponent statuses into one return dict keyed + # by component path. + all_stats = {} + # don't add the root component because we don't manage it + # and can't provide useful info about it. + if self._local_path != LOCAL_PATH_INDICATOR: + # store the stats under the local_path, not comp name so + # it will be sorted correctly + all_stats[self._stat.path] = self._stat + + if subcomponent_stats: + all_stats.update(subcomponent_stats) + + return all_stats + + def checkout(self, verbosity): + """ + If the repo destination directory exists, ensure it is correct (from + correct URL, correct branch or tag), and possibly updateit. + If the repo destination directory does not exist, checkout the correct + branch or tag. + Does not check out sub-externals, see SourceTree.checkout(). + """ + # Make sure we are in correct location + if not os.path.exists(self._repo_dir_path): + # repository directory doesn't exist. Need to check it + # out, and for that we need the base_dir_path to exist + try: + os.makedirs(self._base_dir_path) + except OSError as error: + if error.errno != errno.EEXIST: + msg = 'Could not create directory "{0}"'.format( + self._base_dir_path) + fatal_error(msg) + + if not self._stat: + self.status() + assert self._stat + + if self._stat.source_type != ExternalStatus.STANDALONE: + if verbosity >= VERBOSITY_VERBOSE: + # NOTE(bja, 2018-01) probably do not want to pass + # verbosity in this case, because if (verbosity == + # VERBOSITY_DUMP), then the previous status output would + # also be dumped, adding noise to the output. + self._stat.log_status_message(VERBOSITY_VERBOSE) + + if self._repo: + if self._stat.sync_state == ExternalStatus.STATUS_OK: + # If we're already in sync, avoid showing verbose output + # from the checkout command, unless the verbosity level + # is 2 or more. + checkout_verbosity = verbosity - 1 + else: + checkout_verbosity = verbosity + + self._repo.checkout(self._base_dir_path, self._repo_dir_name, + checkout_verbosity, self.clone_recursive()) + + def replace_subexternal_sourcetree(self, sourcetree): + self._subexternal_sourcetree = sourcetree + + def clone_recursive(self): + 'Return True iff any .gitmodules files should be processed' + # Try recursive .gitmodules unless there is an externals entry + recursive = not self._subexternals_path + + return recursive + + +class SourceTree(object): + """ + SourceTree represents a group of managed externals. + + Those externals may not be checked out locally yet, they might only + have Repository objects pointing to their respective repositories. + """ + + @classmethod + def from_externals_file(cls, parent_repo_dir_path, parent_repo, + externals_path): + """Creates a SourceTree representing the given externals file. + + Looks up a git submodules file as an optional backup if there is no + externals file specified. + + Returns None if there is no externals file (i.e. it's None or 'none'), + or if the externals file hasn't been checked out yet. + + parent_repo_dir_path: parent repo root dir + parent_repo: parent repo. + externals_path: path to externals file, relative to parent_repo_dir_path. + """ + if not os.path.exists(parent_repo_dir_path): + # NOTE(bja, 2017-10) repository has not been checked out + # yet, can't process the externals file. Assume we are + # checking status before code is checkoud out and this + # will be handled correctly later. + return None + + if externals_path.lower() == 'none': + # With explicit 'none', do not look for git submodules file. + return None + + cwd = os.getcwd() + os.chdir(parent_repo_dir_path) + + if not externals_path: + if GitRepository.has_submodules(parent_repo_dir_path): + externals_path = ExternalsDescription.GIT_SUBMODULES_FILENAME + else: + return None + + if not os.path.exists(externals_path): + # NOTE(bja, 2017-10) this check is redundant with the one + # in read_externals_description_file! + msg = ('Externals description file "{0}" ' + 'does not exist! In directory: {1}'.format( + externals_path, parent_repo_dir_path)) + fatal_error(msg) + + externals_root = parent_repo_dir_path + # model_data is a dict-like object which mirrors the file format. + model_data = read_externals_description_file(externals_root, + externals_path) + # ext_description is another dict-like object (see ExternalsDescription) + ext_description = create_externals_description(model_data, + parent_repo=parent_repo) + externals_sourcetree = SourceTree(externals_root, ext_description) + os.chdir(cwd) + return externals_sourcetree + + def __init__(self, root_dir, ext_description, svn_ignore_ancestry=False): + """ + Build a SourceTree object from an ExternalDescription. + + root_dir: the (checked-out) parent repo root dir. + """ + self._root_dir = os.path.abspath(root_dir) + self._all_components = {} # component_name -> _External + self._required_compnames = [] + for comp, desc in ext_description.items(): + local_path = desc[ExternalsDescription.PATH] + required = desc[ExternalsDescription.REQUIRED] + repo_info = desc[ExternalsDescription.REPO] + subexternals_path = desc[ExternalsDescription.EXTERNALS] + + repo = create_repository(comp, + repo_info, + svn_ignore_ancestry=svn_ignore_ancestry) + + sourcetree = None + # Treat a .gitmodules file as a backup externals config + if not subexternals_path: + parent_repo_dir_path = os.path.abspath(os.path.join(root_dir, + local_path)) + if GitRepository.has_submodules(parent_repo_dir_path): + subexternals_path = ExternalsDescription.GIT_SUBMODULES_FILENAME + + # Might return None (if the subexternal isn't checked out yet, or subexternal is None or 'none') + subexternal_sourcetree = SourceTree.from_externals_file( + os.path.join(self._root_dir, local_path), + repo, + subexternals_path) + src = _External(self._root_dir, comp, local_path, required, + subexternals_path, repo, svn_ignore_ancestry, + subexternal_sourcetree) + + self._all_components[comp] = src + if required: + self._required_compnames.append(comp) + + def status(self, relative_path_base=LOCAL_PATH_INDICATOR, + force=False, print_progress=False): + """Return a dictionary of local path->ExternalStatus. + + Notes about the returned dictionary: + * It is keyed by local path (e.g. 'components/mom'), not by + component name (e.g. 'mom'). + * It contains top-level keys for all traversed components, whether + discovered by recursion or top-level. + * It contains entries for all components regardless of whether they + are locally installed or not, or required or optional. +x """ + load_comps = self._all_components.keys() + + summary = {} # Holds merged statuses from all components. + for comp in load_comps: + if print_progress: + printlog('{0}, '.format(comp), end='') + stat = self._all_components[comp].status(force=force, + print_progress=print_progress) + + # Returned status dictionary is keyed by local path; prepend + # relative_path_base if not already there. + stat_final = {} + for name in stat.keys(): + if stat[name].path.startswith(relative_path_base): + stat_final[name] = stat[name] + else: + modified_path = os.path.join(relative_path_base, + stat[name].path) + stat_final[modified_path] = stat[name] + stat_final[modified_path].path = modified_path + summary.update(stat_final) + + return summary + + def _find_installed_optional_components(self): + """Returns a list of installed optional component names, if any.""" + installed_comps = [] + for comp_name, ext in self._all_components.items(): + if comp_name in self._required_compnames: + continue + # Note that in practice we expect this status to be cached. + path_to_stat = ext.status() + + # If any part of this component exists locally, consider it + # installed and therefore eligible for updating. + if any(s.sync_state != ExternalStatus.EMPTY + for s in path_to_stat.values()): + installed_comps.append(comp_name) + return installed_comps + + def checkout(self, verbosity, load_all, load_comp=None): + """ + Checkout or update indicated components into the configured subdirs. + + If load_all is True, checkout all externals (required + optional), recursively. + If load_all is False and load_comp is set, checkout load_comp (and any required subexternals, plus any optional subexternals that are already checked out, recursively) + If load_all is False and load_comp is None, checkout all required externals, plus any optionals that are already checked out, recursively. + """ + if load_all: + tmp_comps = self._all_components.keys() + elif load_comp is not None: + tmp_comps = [load_comp] + else: + local_optional_compnames = self._find_installed_optional_components() + tmp_comps = self._required_compnames + local_optional_compnames + if local_optional_compnames: + printlog('Found locally installed optional components: ' + + ', '.join(local_optional_compnames)) + bad_compnames = set(local_optional_compnames) - set(self._all_components.keys()) + if bad_compnames: + printlog('Internal error: found locally installed components that are not in the global list of all components: ' + ','.join(bad_compnames)) + + if verbosity >= VERBOSITY_VERBOSE: + printlog('Checking out externals: ') + else: + printlog('Checking out externals: ', end='') + + # Sort by path so that if paths are nested the + # parent repo is checked out first. + load_comps = sorted(tmp_comps, key=lambda comp: self._all_components[comp].get_local_path()) + + # checkout. + for comp_name in load_comps: + if verbosity < VERBOSITY_VERBOSE: + printlog('{0}, '.format(comp_name), end='') + else: + # verbose output handled by the _External object, just + # output a newline + printlog(EMPTY_STR) + c = self._all_components[comp_name] + # Does not recurse. + c.checkout(verbosity) + # Recursively check out subexternals, if any. Returns None + # if there's no subexternals path. + component_subexternal_sourcetree = SourceTree.from_externals_file( + c.get_repo_dir_path(), + c.get_repo(), + c.get_subexternals_path()) + c.replace_subexternal_sourcetree(component_subexternal_sourcetree) + if component_subexternal_sourcetree: + component_subexternal_sourcetree.checkout(verbosity, load_all) + printlog('') diff --git a/src/core_atmosphere/tools/manage_externals/manic/utils.py b/src/core_atmosphere/tools/manage_externals/manic/utils.py new file mode 100644 index 0000000000..9c63ffe65e --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/manic/utils.py @@ -0,0 +1,330 @@ +#!/usr/bin/env python3 +""" +Common public utilities for manic package + +""" + +from __future__ import absolute_import +from __future__ import unicode_literals +from __future__ import print_function + +import logging +import os +import subprocess +import sys +from threading import Timer + +from .global_constants import LOCAL_PATH_INDICATOR + +# --------------------------------------------------------------------- +# +# screen and logging output and functions to massage text for output +# +# --------------------------------------------------------------------- + + +def log_process_output(output): + """Log each line of process output at debug level so it can be + filtered if necessary. By default, output is a single string, and + logging.debug(output) will only put log info heading on the first + line. This makes it hard to filter with grep. + + """ + output = output.split('\n') + for line in output: + logging.debug(line) + + +def printlog(msg, **kwargs): + """Wrapper script around print to ensure that everything printed to + the screen also gets logged. + + """ + logging.info(msg) + if kwargs: + print(msg, **kwargs) + else: + print(msg) + sys.stdout.flush() + + +def last_n_lines(the_string, n_lines, truncation_message=None): + """Returns the last n lines of the given string + + Args: + the_string: str + n_lines: int + truncation_message: str, optional + + Returns a string containing the last n lines of the_string + + If truncation_message is provided, the returned string begins with + the given message if and only if the string is greater than n lines + to begin with. + """ + + lines = the_string.splitlines(True) + if len(lines) <= n_lines: + return_val = the_string + else: + lines_subset = lines[-n_lines:] + str_truncated = ''.join(lines_subset) + if truncation_message: + str_truncated = truncation_message + '\n' + str_truncated + return_val = str_truncated + + return return_val + + +def indent_string(the_string, indent_level): + """Indents the given string by a given number of spaces + + Args: + the_string: str + indent_level: int + + Returns a new string that is the same as the_string, except that + each line is indented by 'indent_level' spaces. + + In python3, this can be done with textwrap.indent. + """ + + lines = the_string.splitlines(True) + padding = ' ' * indent_level + lines_indented = [padding + line for line in lines] + return ''.join(lines_indented) + +# --------------------------------------------------------------------- +# +# error handling +# +# --------------------------------------------------------------------- + + +def fatal_error(message): + """ + Error output function + """ + logging.error(message) + raise RuntimeError("{0}ERROR: {1}".format(os.linesep, message)) + + +# --------------------------------------------------------------------- +# +# Data conversion / manipulation +# +# --------------------------------------------------------------------- +def str_to_bool(bool_str): + """Convert a sting representation of as boolean into a true boolean. + + Conversion should be case insensitive. + """ + value = None + str_lower = bool_str.lower() + if str_lower in ('true', 't'): + value = True + elif str_lower in ('false', 'f'): + value = False + if value is None: + msg = ('ERROR: invalid boolean string value "{0}". ' + 'Must be "true" or "false"'.format(bool_str)) + fatal_error(msg) + return value + + +REMOTE_PREFIXES = ['http://', 'https://', 'ssh://', 'git@'] + + +def is_remote_url(url): + """check if the user provided a local file path instead of a + remote. If so, it must be expanded to an absolute + path. + + """ + remote_url = False + for prefix in REMOTE_PREFIXES: + if url.startswith(prefix): + remote_url = True + return remote_url + + +def split_remote_url(url): + """check if the user provided a local file path or a + remote. If remote, try to strip off protocol info. + + """ + remote_url = is_remote_url(url) + if not remote_url: + return url + + for prefix in REMOTE_PREFIXES: + url = url.replace(prefix, '') + + if '@' in url: + url = url.split('@')[1] + + if ':' in url: + url = url.split(':')[1] + + return url + + +def expand_local_url(url, field): + """check if the user provided a local file path instead of a + remote. If so, it must be expanded to an absolute + path. + + Note: local paths of LOCAL_PATH_INDICATOR have special meaning and + represent local copy only, don't work with the remotes. + + """ + remote_url = is_remote_url(url) + if not remote_url: + if url.strip() == LOCAL_PATH_INDICATOR: + pass + else: + url = os.path.expandvars(url) + url = os.path.expanduser(url) + if not os.path.isabs(url): + msg = ('WARNING: Externals description for "{0}" contains a ' + 'url that is not remote and does not expand to an ' + 'absolute path. Version control operations may ' + 'fail.\n\nurl={1}'.format(field, url)) + printlog(msg) + else: + url = os.path.normpath(url) + return url + + +# --------------------------------------------------------------------- +# +# subprocess +# +# --------------------------------------------------------------------- + +# Give the user a helpful message if we detect that a command seems to +# be hanging. +_HANGING_SEC = 300 + + +def _hanging_msg(working_directory, command): + print(""" + +Command '{command}' +from directory {working_directory} +has taken {hanging_sec} seconds. It may be hanging. + +The command will continue to run, but you may want to abort +manage_externals with ^C and investigate. A possible cause of hangs is +when svn or git require authentication to access a private +repository. On some systems, svn and git requests for authentication +information will not be displayed to the user. In this case, the program +will appear to hang. Ensure you can run svn and git manually and access +all repositories without entering your authentication information. + +""".format(command=command, + working_directory=working_directory, + hanging_sec=_HANGING_SEC)) + + +def execute_subprocess(commands, status_to_caller=False, + output_to_caller=False): + """Wrapper around subprocess.check_output to handle common + exceptions. + + check_output runs a command with arguments and waits + for it to complete. + + check_output raises an exception on a nonzero return code. if + status_to_caller is true, execute_subprocess returns the subprocess + return code, otherwise execute_subprocess treats non-zero return + status as an error and raises an exception. + + """ + cwd = os.getcwd() + msg = 'In directory: {0}\nexecute_subprocess running command:'.format(cwd) + logging.info(msg) + commands_str = ' '.join(commands) + logging.info(commands_str) + return_to_caller = status_to_caller or output_to_caller + status = -1 + output = '' + hanging_timer = Timer(_HANGING_SEC, _hanging_msg, + kwargs={"working_directory": cwd, + "command": commands_str}) + hanging_timer.start() + try: + output = subprocess.check_output(commands, stderr=subprocess.STDOUT, + universal_newlines=True) + log_process_output(output) + status = 0 + except OSError as error: + msg = failed_command_msg( + 'Command execution failed. Does the executable exist?', + commands) + logging.error(error) + fatal_error(msg) + except ValueError as error: + msg = failed_command_msg( + 'DEV_ERROR: Invalid arguments trying to run subprocess', + commands) + logging.error(error) + fatal_error(msg) + except subprocess.CalledProcessError as error: + # Only report the error if we are NOT returning to the + # caller. If we are returning to the caller, then it may be a + # simple status check. If returning, it is the callers + # responsibility determine if an error occurred and handle it + # appropriately. + if not return_to_caller: + msg_context = ('Process did not run successfully; ' + 'returned status {0}'.format(error.returncode)) + msg = failed_command_msg(msg_context, commands, + output=error.output) + logging.error(error) + logging.error(msg) + log_process_output(error.output) + fatal_error(msg) + status = error.returncode + finally: + hanging_timer.cancel() + + if status_to_caller and output_to_caller: + ret_value = (status, output) + elif status_to_caller: + ret_value = status + elif output_to_caller: + ret_value = output + else: + ret_value = None + + return ret_value + + +def failed_command_msg(msg_context, command, output=None): + """Template for consistent error messages from subprocess calls. + + If 'output' is given, it should provide the output from the failed + command + """ + + if output: + output_truncated = last_n_lines(output, 20, + truncation_message='[... Output truncated for brevity ...]') + errmsg = ('Failed with output:\n' + + indent_string(output_truncated, 4) + + '\nERROR: ') + else: + errmsg = '' + + command_str = ' '.join(command) + errmsg += """In directory + {cwd} +{context}: + {command} +""".format(cwd=os.getcwd(), context=msg_context, command=command_str) + + if output: + errmsg += 'See above for output from failed command.\n' + + return errmsg diff --git a/src/core_atmosphere/tools/manage_externals/version.txt b/src/core_atmosphere/tools/manage_externals/version.txt new file mode 100644 index 0000000000..cbda54c515 --- /dev/null +++ b/src/core_atmosphere/tools/manage_externals/version.txt @@ -0,0 +1 @@ +manic-1.2.24-3-gba00e50 diff --git a/src/core_atmosphere/utils/Makefile b/src/core_atmosphere/utils/Makefile index 03034c7418..39765f9ee9 100644 --- a/src/core_atmosphere/utils/Makefile +++ b/src/core_atmosphere/utils/Makefile @@ -1,10 +1,14 @@ .SUFFIXES: .F .o -all: build_tables - mv build_tables ../../.. +ifdef PHYSICS + UTILS = build_tables +endif + +all: $(UTILS) build_tables: build_tables.o atmphys_build_tables_thompson.o $(LINKER) $(LDFLAGS) -o build_tables build_tables.o atmphys_build_tables_thompson.o -L../../framework -L../physics -lphys -lframework $(LIBS) -L../../external/esmf_time_f90 -lesmf_time + mv build_tables ../../.. build_tables.o: \ @@ -23,7 +27,7 @@ clean: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" $(CPP) $(CPPFLAGS) $(PHYSICS) $(CPPINCLUDES) $< > $*.f90 - $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf -I../../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_wrf -I../../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(PHYSICS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../../framework -I../../operators -I../physics -I../physics/physics_mmm -I../physics/physics_wrf -I../../external/esmf_time_f90 endif diff --git a/src/core_atmosphere/utils/atmphys_build_tables_thompson.F b/src/core_atmosphere/utils/atmphys_build_tables_thompson.F index 83ac7b9014..981dee90ea 100644 --- a/src/core_atmosphere/utils/atmphys_build_tables_thompson.F +++ b/src/core_atmosphere/utils/atmphys_build_tables_thompson.F @@ -25,85 +25,91 @@ module atmphys_build_tables_thompson subroutine build_tables_thompson !================================================================================================================= + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + !local variables: logical, parameter:: l_mp_tables = .false. integer:: istatus + integer:: mp_unit !----------------------------------------------------------------------------------------------------------------- !--- partial initialization before building the look-up tables: call thompson_init(l_mp_tables) + call mpas_new_unit(mp_unit, unformatted = .true.) + !--- building look-up table for rain collecting graupel: write(0,*) write(0,*) '--- building MP_THOMPSON_QRacrQG_DATA.DBL' - open(unit=11,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_QRacrQG_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_QRacrQG_DATA.DBL') return end if call qr_acr_qg - write(11) tcg_racg - write(11) tmr_racg - write(11) tcr_gacr - write(11) tmg_gacr - write(11) tnr_racg - write(11) tnr_gacr - close(unit=11) + write(mp_unit) tcg_racg + write(mp_unit) tmr_racg + write(mp_unit) tcr_gacr + write(mp_unit) tmg_gacr + write(mp_unit) tnr_racg + write(mp_unit) tnr_gacr + close(unit=mp_unit) !--- building look-up table for rain collecting snow: write(0,*) write(0,*) '--- building MP_THOMPSON_QRacrQS_DATA.DBL' - open(unit=11,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_QRacrQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_QRacrQS_DATA.DBL') return end if call qr_acr_qs - write(11)tcs_racs1 - write(11)tmr_racs1 - write(11)tcs_racs2 - write(11)tmr_racs2 - write(11)tcr_sacr1 - write(11)tms_sacr1 - write(11)tcr_sacr2 - write(11)tms_sacr2 - write(11)tnr_racs1 - write(11)tnr_racs2 - write(11)tnr_sacr1 - write(11)tnr_sacr2 - close(unit=11) + write(mp_unit)tcs_racs1 + write(mp_unit)tmr_racs1 + write(mp_unit)tcs_racs2 + write(mp_unit)tmr_racs2 + write(mp_unit)tcr_sacr1 + write(mp_unit)tms_sacr1 + write(mp_unit)tcr_sacr2 + write(mp_unit)tms_sacr2 + write(mp_unit)tnr_racs1 + write(mp_unit)tnr_racs2 + write(mp_unit)tnr_sacr1 + write(mp_unit)tnr_sacr2 + close(unit=mp_unit) !--- building look-up table for freezing of cloud droplets: write(0,*) write(0,*) '--- building MP_THOMPSON_freezeH2O_DATA.DBL' - open(unit=11,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_freezeH2O_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_freezeH2O_DATA.DBL') return end if call freezeH2O - write(11) tpi_qrfz - write(11) tni_qrfz - write(11) tpg_qrfz - write(11) tnr_qrfz - write(11) tpi_qcfz - write(11) tni_qcfz - close(unit=11) + write(mp_unit) tpi_qrfz + write(mp_unit) tni_qrfz + write(mp_unit) tpg_qrfz + write(mp_unit) tnr_qrfz + write(mp_unit) tpi_qcfz + write(mp_unit) tni_qcfz + close(unit=mp_unit) !--- building look-up table for autoconversion of cloud ice to snow: write(0,*) write(0,*) '--- building MP_THOMPSON_QIautQS_DATA.DBL' - open(unit=11,file='MP_THOMPSON_QIautQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) + open(unit=mp_unit,file='MP_THOMPSON_QIautQS_DATA.DBL',form='unformatted',status='new',iostat=istatus) if (istatus /= 0) then call print_parallel_mesg('MP_THOMPSON_QIautQS_DATA.DBL') return end if call qi_aut_qs - write(11) tpi_ide - write(11) tps_iaus - write(11) tni_iaus - close(unit=11) + write(mp_unit) tpi_ide + write(mp_unit) tps_iaus + write(mp_unit) tni_iaus + close(unit=mp_unit) + call mpas_release_unit(mp_unit) write(0,*) write(0,*) 'Finished building all tables.' diff --git a/src/core_init_atmosphere/CMakeLists.txt b/src/core_init_atmosphere/CMakeLists.txt new file mode 100644 index 0000000000..0835d55be9 --- /dev/null +++ b/src/core_init_atmosphere/CMakeLists.txt @@ -0,0 +1,79 @@ +# MPAS/src/core_init_atmosphere +# +# Targets +# MPAS::core::init_atmosphere + +## Generated includes +set(init_atm_core_inc + block_dimension_routines.inc + core_variables.inc + define_packages.inc + domain_variables.inc + namelist_call.inc + namelist_defines.inc + setup_immutable_streams.inc + structs_and_variables.inc) + +## core_init_atosphere +set(init_atm_core_srcs + mpas_atm_advection.F + mpas_atmphys_constants.F + mpas_atmphys_date_time.F + mpas_atmphys_functions.F + mpas_atmphys_initialize_real.F + mpas_atmphys_utilities.F + mpas_geotile_manager.F + mpas_init_atm_bitarray.F + mpas_init_atm_cases.F + mpas_init_atm_core.F + mpas_init_atm_core_interface.F + mpas_init_atm_thompson_aerosols.F + mpas_init_atm_gwd.F + mpas_init_atm_hinterp.F + mpas_init_atm_llxy.F + mpas_init_atm_queue.F + mpas_init_atm_read_met.F + mpas_init_atm_static.F + mpas_init_atm_surface.F + mpas_init_atm_vinterp.F + mpas_kd_tree.F + mpas_parse_geoindex.F + mpas_stack.F + read_geogrid.c) + +add_library(core_init_atmosphere ${init_atm_core_srcs}) +if (${DO_PHYSICS}) + target_compile_definitions(core_init_atmosphere PRIVATE DO_PHYSICS) +endif () +if (MPAS_DOUBLE_PRECISION) + set(CMAKE_Fortran_FLAGS "${CMAKE_Fortran_FLAGS} -fdefault-real-8 -fdefault-double-8") +else () + target_compile_definitions(core_init_atmosphere PRIVATE SINGLE_PRECISION) +endif () +if (${CMAKE_BUILD_TYPE} MATCHES "Debug") + target_compile_definitions(core_init_atmosphere PRIVATE MPAS_DEBUG) +endif () +if (${PIO_FOUND}) + FILE(STRINGS ${PIO_PREFIX}/lib/libpio.settings PIO_SETTINGS) + foreach (setting ${PIO_SETTINGS}) + string(FIND ${setting} "PIO Version" found) + if (${found} GREATER -1) + string(FIND ${setting} "2." pos) + if (${pos} GREATER -1) + set(PIO_VERSION 2) + else () + set(PIO_VERSION 1) + endif () + break() + endif () + endforeach () + if (${PIO_VERSION} EQUAL 1) + target_compile_definitions(core_init_atmosphere PRIVATE USE_PIO1) + else () + target_compile_definitions(core_init_atmosphere PRIVATE USE_PIO2) + endif () + target_compile_definitions(core_init_atmosphere PRIVATE MPAS_PIO_SUPPORT) +endif () +target_compile_definitions(core_init_atmosphere PRIVATE mpas=1) +target_compile_definitions(framework PRIVATE MPAS_NATIVE_TIMERS) +mpas_core_target(CORE init_atmosphere TARGET core_init_atmosphere INCLUDES ${init_atm_core_inc}) diff --git a/src/core_init_atmosphere/Makefile b/src/core_init_atmosphere/Makefile index 9579f48573..984b7c367a 100644 --- a/src/core_init_atmosphere/Makefile +++ b/src/core_init_atmosphere/Makefile @@ -14,12 +14,17 @@ OBJS = \ mpas_init_atm_gwd.o \ mpas_init_atm_surface.o \ mpas_init_atm_vinterp.o \ + mpas_init_atm_thompson_aerosols.o \ read_geogrid.o \ mpas_atmphys_constants.o \ mpas_atmphys_date_time.o \ mpas_atmphys_functions.o \ mpas_atmphys_initialize_real.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_stack.o \ + mpas_kd_tree.o \ + mpas_parse_geoindex.o \ + mpas_geotile_manager.o all: core_hyd @@ -37,7 +42,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi @@ -53,6 +58,7 @@ mpas_init_atm_cases.o: \ mpas_init_atm_static.o \ mpas_init_atm_gwd.o \ mpas_init_atm_surface.o \ + mpas_init_atm_thompson_aerosols.o \ mpas_init_atm_vinterp.o \ mpas_atmphys_constants.o \ mpas_atmphys_functions.o \ @@ -60,23 +66,43 @@ mpas_init_atm_cases.o: \ mpas_init_atm_hinterp.o: mpas_init_atm_queue.o mpas_init_atm_bitarray.o +mpas_init_atm_thompson_aerosols.o: \ + mpas_init_atm_read_met.o \ + mpas_init_atm_hinterp.o \ + mpas_init_atm_llxy.o \ + mpas_init_atm_vinterp.o \ + mpas_atmphys_date_time.o \ + mpas_atmphys_utilities.o + mpas_advection.o: mpas_init_atm_read_met.o: read_geogrid.o: +mpas_kd_tree.o: + mpas_init_atm_llxy.o: mpas_init_atm_core_interface.o: mpas_init_atm_core.o mpas_init_atm_core.o: mpas_advection.o mpas_init_atm_cases.o +mpas_stack.o: + +mpas_parse_geoindex.o: + +mpas_geotile_manager.o: mpas_parse_geoindex.o + mpas_init_atm_static.o: \ mpas_atm_advection.o \ mpas_init_atm_hinterp.o \ mpas_init_atm_llxy.o \ - mpas_atmphys_utilities.o + mpas_atmphys_utilities.o \ + mpas_stack.o \ + mpas_kd_tree.o \ + mpas_parse_geoindex.o \ + mpas_geotile_manager.o mpas_init_atm_surface.o: \ mpas_init_atm_hinterp.o \ @@ -99,10 +125,10 @@ clean: .F.o: $(RM) $@ $*.mod ifeq "$(GEN_F90)" "true" - $(CPP) $(CPPFLAGS) $(CPPINCLUDES) $< > $*.f90 + $(CPP) $(CPPFLAGS) $(CPPINCLUDES) -I./inc $< > $*.f90 $(FC) $(FFLAGS) -c $*.f90 $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 else - $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I../framework -I../operators -I../external/esmf_time_f90 + $(FC) $(CPPFLAGS) $(FFLAGS) -c $*.F $(CPPINCLUDES) $(FCINCLUDES) -I./inc -I../framework -I../operators -I../external/esmf_time_f90 endif .c.o: diff --git a/src/core_init_atmosphere/Registry.xml b/src/core_init_atmosphere/Registry.xml index c1e539f27e..cb1216ca4c 100644 --- a/src/core_init_atmosphere/Registry.xml +++ b/src/core_init_atmosphere/Registry.xml @@ -1,5 +1,5 @@ - + @@ -38,6 +38,10 @@ description="The number of first-guess soil layers"/> + + @@ -51,16 +55,18 @@ + 8 = surface field (SST, sea-ice) update file for use with real-data simulations \newline + 9 = lateral boundary conditions update file for use with real-data simulations \newline + 13 = CAM-MPAS 3-d grid with specified topography and zeta levels" + possible_values="1 -- 9"/> + + @@ -108,7 +119,7 @@ + + - + possible_values="`USGS' or `MODIFIED_IGBP_MODIS_NOAH'"/> - + + + + + + + + + + + + + + - @@ -214,7 +265,7 @@ + + + @@ -289,12 +345,15 @@ + + + @@ -345,6 +404,10 @@ + + + + @@ -352,8 +415,10 @@ - + + + @@ -361,6 +426,11 @@ + + + + + @@ -372,14 +442,14 @@ - + + - @@ -402,6 +472,7 @@ + @@ -438,6 +509,10 @@ + + + + @@ -445,8 +520,10 @@ - + + + @@ -454,6 +531,11 @@ + + + + + @@ -465,14 +547,14 @@ - + + - @@ -485,9 +567,10 @@ + - + @@ -531,10 +614,24 @@ immutable="true"> + + + + + + + + @@ -667,6 +764,9 @@ + + @@ -681,6 +781,9 @@ + + @@ -711,83 +814,147 @@ + + + + + + + + + + + + + + + - + - + + description="asymmetry of subgrid-scale orography for westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for southerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for south-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="asymmetry of subgrid-scale orography for north-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for southerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for south-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + description="effective orographic length for north-westerly flow" + packages="gwd_stage_out;vertical_stage_out;met_stage_out"/> + + + + + + + + description="terrain influence in vertical coordinate, $h_s(x,y,\zeta)$ in Klemp (MWR 2011)" + packages="vertical_stage_out;met_stage_out"/> + description="Geometric height of layer interfaces" + packages="vertical_stage_out;met_stage_out"/> + description="Reciprocal dzw" + packages="vertical_stage_out;met_stage_out"/> + description="d(zeta) at w levels" + packages="vertical_stage_out;met_stage_out"/> + description="Reciprocal dzu" + packages="vertical_stage_out;met_stage_out"/> + description="Weight for linear interpolation to w(k) point for u(k) level variable" + packages="vertical_stage_out;met_stage_out"/> + description="Weight for linear interpolation to w(k) point for u(k-1) level variable" + packages="vertical_stage_out;met_stage_out"/> + description="dz/dx on horizontal coordinate surfaces at u levels" + packages="vertical_stage_out;met_stage_out"/> + description="d(zeta)/dz, vertical metric term" + packages="vertical_stage_out;met_stage_out"/> + description="Coefficients for contribution from u to omega diagnosis, edge-oriented" + packages="vertical_stage_out;met_stage_out"/> + description="Coefficients for 3rd-order correction to contribution from u to omega diagnosis, edge-oriented" + packages="vertical_stage_out;met_stage_out"/> + description="w-damping coefficient" + packages="vertical_stage_out;met_stage_out"/> + description="u reference profile" + packages="met_stage_out"/> + + + description="theta reference profile" + packages="met_stage_out"/> + description="qv reference profile" + packages="met_stage_out"/> + + + + + + + + + + @@ -815,19 +997,26 @@ + + + description="Horizontal normal velocity at edges" + packages="met_stage_out"/> + description="Vertical velocity at vertical cell faces" + packages="met_stage_out"/> + description="Dry air density divided by d(zeta)/dz" + packages="met_stage_out"/> + description="Moist potential temperature: theta*(1+q_v*R_v/R_d)" + packages="met_stage_out"/> - + @@ -836,215 +1025,326 @@ + + + + + description="Initial depth of ocean mix layer" + packages="met_stage_out"/> + + + + + + + + + + + + + + + + + + + + + + + + description="First guess zonal wind component" + packages="first_guess_field"/> + description="First guess merdian wind component" + packages="first_guess_field"/> + description="First guess temperature" + packages="first_guess_field"/> + description="First guess pressure" + packages="first_guess_field"/> + description="First guess geopotential height" + packages="first_guess_field"/> + description="First guess relative humidity with respect to liquid water" + packages="first_guess_field"/> + description="First guess specific humidity" + packages="first_guess_field"/> + description="First guess soil height" + packages="first_guess_field"/> + description="First guess surface pressure" + packages="first_guess_field"/> + description="First guess mean sea level pressure" + packages="first_guess_field"/> + description="First guess depth of soil layer bottom" + packages="first_guess_field"/> + description="First guess soil layer thickness" + packages="first_guess_field"/> + description="First guess depth of centers of soil levels" + packages="first_guess_field"/> + description="First guess soil temperature" + packages="first_guess_field"/> + description="First guess soil moisture" + packages="first_guess_field"/> + description="depth of soil layer bottom" + packages="met_stage_out"/> + description="soil layer thickness" + packages="met_stage_out"/> + description="depth of centers of soil layers" + packages="met_stage_out"/> + description="soil equivalent liquid water " + packages="met_stage_out"/> + description="soil moisture" + packages="met_stage_out"/> + description="soil layer temperature" + packages="met_stage_out"/> + description="soil moisture threshold below which transpiration begins to stress" + packages="met_stage_out"/> + description="deep soil temperature" + packages="met_stage_out"/> + description="ground or water surface temperature" + packages="met_stage_out"/> + description="sea-surface temperature" + packages="met_stage_out;sfc_update"/> + description="snow water equivalent" + packages="met_stage_out"/> + description="flag for snow on ground (=0 no snow; =1,otherwise" + packages="met_stage_out"/> + description="physical snow depth" + packages="met_stage_out"/> + description="fractional area coverage of sea-ice" + packages="met_stage_out;sfc_update"/> + description="sea-ice flag (0=no seaice; =1 otherwise)" + packages="met_stage_out"/> + description="geopotential height vertically interpolated from first guess" + packages="met_stage_out"/> + description="vegetation fraction" + packages="met_stage_out"/> + description="background surface albedo" + packages="met_stage_out"/> + description="land-ocean mask (1=land including sea-ice ; 2=ocean)" + packages="met_stage_out"/> + description="10-meter zonal wind" + packages="met_stage_out"/> + description="10-meter meridional wind" + packages="met_stage_out"/> + description="2-meter specific humidity" + packages="met_stage_out"/> + description="2-meter relative humidity" + packages="met_stage_out"/> + description="2-meter temperature" + packages="met_stage_out"/> + description="Perturbation pressure" + packages="met_stage_out"/> + description="Dry air density" + packages="met_stage_out"/> + description="Potential temperature" + packages="met_stage_out"/> + description="Horizontal tangential velocity at edges" + packages="met_stage_out"/> + description="Relative humidity" + packages="met_stage_out"/> + description="Specific humidity" + packages="met_stage_out"/> + description="Cartesian x-component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Cartesian y-component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Cartesian z-component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Zonal component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Meridional component of reconstructed horizontal velocity at cell centers" + packages="met_stage_out"/> + description="Exner function" + packages="met_stage_out"/> + description="Base-state Exner function" + packages="met_stage_out"/> + description="reference state rho*theta/zz" + packages="met_stage_out"/> + description="Pressure" + packages="met_stage_out"/> + description="Base state pressure" + packages="met_stage_out"/> + description="Base state dry air density" + packages="met_stage_out"/> + description="Base state potential temperature" + packages="met_stage_out"/> + description="rho_d/rho_m at w points" + packages="met_stage_out"/> + description="Diagnosed surface pressure" + packages="met_stage_out"/> + description="horizontal momentum at cell edge (rho*u/zz)" + packages="met_stage_out"/> + description="rho*omega/zz carried at w points" + packages="met_stage_out"/> + description="rho*theta_m/zz perturbation from the reference state value" + packages="met_stage_out"/> + description="rho/zz perturbation from the reference state value, advanced over acoustic steps" + packages="met_stage_out"/> + description="precipitable water" + packages="met_stage_out"/> diff --git a/src/core_init_atmosphere/mpas_atm_advection.F b/src/core_init_atmosphere/mpas_atm_advection.F index 1602d09cfa..f4d44c984e 100644 --- a/src/core_init_atmosphere/mpas_atm_advection.F +++ b/src/core_init_atmosphere/mpas_atm_advection.F @@ -757,6 +757,7 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere ! local variables real (kind=RKIND), dimension(:,:), pointer :: defc_a, defc_b + real (kind=RKIND), dimension(:,:), pointer :: cell_gradient_coef_x, cell_gradient_coef_y integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell, cellsOnCell, verticesOnCell integer, dimension(:), pointer :: nEdgesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell @@ -777,11 +778,13 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere integer :: iv logical :: do_the_cell - real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, area_cellt + real (kind=RKIND) :: area_cell, sint2, cost2, sint_cost, dx, dy call mpas_pool_get_array(mesh, 'defc_a', defc_a) call mpas_pool_get_array(mesh, 'defc_b', defc_b) + call mpas_pool_get_array(mesh, 'cell_gradient_coef_x', cell_gradient_coef_x) + call mpas_pool_get_array(mesh, 'cell_gradient_coef_y', cell_gradient_coef_y) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) @@ -797,6 +800,9 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere defc_a(:,:) = 0. defc_b(:,:) = 0. + cell_gradient_coef_x(:,:) = 0. + cell_gradient_coef_y(:,:) = 0. + pii = 2.*asin(1.0) do iCell = 1, nCells @@ -817,15 +823,17 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere if (.not. do_the_cell) cycle + ! compute poynomial fit for this cell if all needed neighbors exist -! compute poynomial fit for this cell if all needed neighbors exist if (on_a_sphere) then + ! xc holds the center point and the vertex points of the cell, + ! normalized to a sphere or radius 1. + xc(1) = xCell(iCell)/sphere_radius yc(1) = yCell(iCell)/sphere_radius zc(1) = zCell(iCell)/sphere_radius - do i=2,n iv = verticesOnCell(i-1,iCell) xc(i) = xVertex(iv)/sphere_radius @@ -842,14 +850,22 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere if (zc(1) == 1.0) then theta_abs(iCell) = pii/2. else + ! theta_abs is the angle to the first vertex from the center, normalized so that + ! an eastward pointing vector has a angle of 0. theta_abs(iCell) = pii/2. - sphere_angle( xc(1), yc(1), zc(1), & xc(2), yc(2), zc(2), & 0.0_RKIND, 0.0_RKIND, 1.0_RKIND ) end if + ! here we are constructing the tangent-plane cell. + ! thetat is the angle in the (x,y) tangent-plane coordinate from + ! the cell center to each vertex, normalized so that an + ! eastward pointing vector has a angle of 0. -! angles from cell center to neighbor centers (thetav) + ! dl_sphere is the spherical distance from the cell center + ! to the sphere vertex points for the cell. + thetat(1) = theta_abs(iCell) do i=1,n-1 ip2 = i+2 @@ -858,22 +874,13 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere thetav(i) = sphere_angle( xc(1), yc(1), zc(1), & xc(i+1), yc(i+1), zc(i+1), & xc(ip2), yc(ip2), zc(ip2) ) - dl_sphere(i) = sphere_radius*arc_length( xc(1), yc(1), zc(1), & - xc(i+1), yc(i+1), zc(i+1) ) + xc(i+1), yc(i+1), zc(i+1) ) + if(i.gt.1) thetat(i) = thetat(i-1)+thetav(i-1) end do - length_scale = 1. - do i=1,n-1 - dl_sphere(i) = dl_sphere(i)/length_scale - end do + ! xp and yp are the tangent-plane vertex points with the cell center at (0,0) - thetat(1) = 0. ! this defines the x direction, cell center 1 -> -! thetat(1) = theta_abs(iCell) ! this defines the x direction, longitude line - do i=2,n-1 - thetat(i) = thetat(i-1) + thetav(i-1) - end do - do i=1,n-1 xp(i) = cos(thetat(i)) * dl_sphere(i) yp(i) = sin(thetat(i)) * dl_sphere(i) @@ -894,28 +901,21 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end if -! thetat(1) = 0. - thetat(1) = theta_abs(iCell) - do i=2,n-1 - ip1 = i+1 - if (ip1 == n) ip1 = 1 - thetat(i) = plane_angle( 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & - xp(i)-xp(i-1), yp(i)-yp(i-1), 0.0_RKIND, & - xp(ip1)-xp(i), yp(ip1)-yp(i), 0.0_RKIND, & - 0.0_RKIND, 0.0_RKIND, 1.0_RKIND) - thetat(i) = thetat(i) + thetat(i-1) - end do + ! (1) compute cell area on the tangent plane used in the integrals + ! (2) compute angle of cell edge normal vector. here we are repurposing thetat area_cell = 0. - area_cellt = 0. do i=1,n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 - dl = sqrt((xp(ip1)-xp(i))**2 + (yp(ip1)-yp(i))**2) + dx = xp(ip1)-xp(i) + dy = yp(ip1)-yp(i) area_cell = area_cell + 0.25*(xp(i)+xp(ip1))*(yp(ip1)-yp(i)) - 0.25*(yp(i)+yp(ip1))*(xp(ip1)-xp(i)) - area_cellt = area_cellt + (0.25*(xp(i)+xp(ip1))*cos(thetat(i)) + 0.25*(yp(i)+yp(ip1))*sin(thetat(i)))*dl + thetat(i) = atan2(dy,dx)-pii/2. end do + ! coefficients - see documentation for the formulas. + do i=1,n-1 ip1 = i+1 if (ip1 == n) ip1 = 1 @@ -925,6 +925,8 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere sint_cost = sin(thetat(i))*cos(thetat(i)) defc_a(i,iCell) = dl*(cost2 - sint2)/area_cell defc_b(i,iCell) = dl*2.*sint_cost/area_cell + cell_gradient_coef_x(i,iCell) = dl*cos(thetat(i))/area_cell + cell_gradient_coef_y(i,iCell) = dl*sin(thetat(i))/area_cell if (cellsOnEdge(1,EdgesOnCell(i,iCell)) /= iCell) then defc_a(i,iCell) = - defc_a(i,iCell) defc_b(i,iCell) = - defc_b(i,iCell) @@ -936,4 +938,4 @@ subroutine atm_initialize_deformation_weights( mesh, nCells, on_a_sphere, sphere end subroutine atm_initialize_deformation_weights -end module atm_advection + end module atm_advection diff --git a/src/core_init_atmosphere/mpas_geotile_manager.F b/src/core_init_atmosphere/mpas_geotile_manager.F new file mode 100644 index 0000000000..04f9c60d0b --- /dev/null +++ b/src/core_init_atmosphere/mpas_geotile_manager.F @@ -0,0 +1,1158 @@ +module mpas_geotile_manager + + use iso_c_binding, only : c_float, c_char + + use mpas_constants, only : pii + use mpas_kind_types, only : RKIND, StrKIND + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_POOL_SILENT + use mpas_pool_routines, only : mpas_pool_type, mpas_pool_destroy_pool, mpas_pool_create_pool + use mpas_pool_routines, only : mpas_pool_add_config, mpas_pool_get_config + use mpas_pool_routines, only : mpas_pool_get_error_level, mpas_pool_set_error_level + use mpas_stack + + implicit none + + public :: mpas_geotile_mgr_type + public :: mpas_geotile_type + public :: mpas_latlon_to_xyz + + private + + type mpas_geotile_mgr_type + type (mpas_pool_type), pointer :: pool + type (tile_hash), dimension(:,:), pointer :: hash + type (mpas_stack_type), pointer :: stack + + character (len=StrKIND) :: directory ! Path to the dataset directory + character (len=StrKIND) :: index ! Path the index file of the dataset directory + + integer :: nTileX ! Number of tiles in the X direction + integer :: nTileY ! Number of tiles in the Y direction + integer :: pixel_nx ! Total number of pixels in the x direction + integer :: pixel_ny ! Total number of pixels in the y direction + contains + ! Public Procedures + procedure, public :: init => mpas_geotile_mgr_init + procedure, public :: finalize => mpas_geotile_mgr_finalize + procedure, public :: get_tile => mpas_geotile_mgr_get_tile + procedure, public :: latlon_to_pixel => mpas_geotile_mgr_latlon_to_pixel + procedure, public :: tile_to_latlon => mpas_geotile_mgr_tile_to_latlon + procedure, public :: push_neighbors => mpas_geotile_mgr_push_neighbors + + ! Stack Procedures + procedure, public :: push_tile => mpas_geotile_mgr_push_tile + procedure, public :: pop_tile => mpas_geotile_mgr_pop_tile + procedure, public :: is_stack_empty => mpas_geotile_mgr_stack_is_empty + + ! Private Procedures + procedure, private :: search_tile => mpas_geotile_mgr_search_tile + procedure, private :: add_tile => mpas_geotile_mgr_add_tile + procedure, private :: gen_filename => mpas_geotile_mgr_gen_tile_name + procedure, private :: hash_to_ll => mpas_geotile_mgr_hash_to_latlon + end type mpas_geotile_mgr_type + + + type, extends(mpas_stack_payload_type) :: mpas_geotile_type + real (c_float), dimension(:,:,:), pointer :: tile + + character (len=StrKIND) :: fname ! Path to the file that contains the data for this tile + integer :: hash_x ! The x offset of this tile in the hash table + integer :: hash_y ! The y offset of this tile in the hash table + + integer :: x, y ! The tiles range, in pixels + logical :: is_processed = .false. + end type mpas_geotile_type + + + type tile_hash + type(mpas_geotile_type), pointer :: ptr => null() + end type tile_hash + + + contains + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_init => init + ! + !> \brief Initialize a mpas_geotile_mgr class + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Initialize a geotile manager class by parsing the index file located + !> within path and allocated needed data structures for static interpolation. + !> Init should be called before calling any other mpas_geotile_mgr_type + !> procedures. If path is not a directory or no index file is found in path, + !> 1 will be returned. Upon success 0 will be returned. + !> + !> This function will also allocate the following variables in the pool attribute + !> of this geotile manager instance if they are not found within the index file: + !> * tile_bdr = 0 + !> * signed = 0 ! No + !> * scalefactor = 1.0_RKIND + !> * endian = "big" + !> * iswater = 16 + !> * islake = -1 + !> * isice = 24 + !> * isurban = 1 + !> * isoilwater = 14 + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_init(mgr, path) result(ierr) + + use mpas_parse_geoindex, only : mpas_parse_index + + implicit none + + ! Input variables + class (mpas_geotile_mgr_type) :: mgr + character (len=*), intent(in) :: path + + ! Local variables + character (len=StrKIND), pointer :: fieldType + character (len=StrKIND), pointer :: endian + integer, pointer :: tile_nx ! Number of pixels in the x-direction for a single tile + integer, pointer :: tile_ny ! Number of pixels in the y-direction for a single tile + integer, pointer :: tile_nz ! Number of pixels in the z-direction for a single tile + integer, pointer :: tile_z_start, tile_z_end + integer, pointer :: signed + integer, pointer :: tile_bdr + integer, pointer :: iswater, islake, isice, isurban, isoilwater + integer, pointer :: category_min, category_max + integer :: err_level + real (kind=RKIND), pointer :: dx ! Grid spacing in the x-direction + real (kind=RKIND), pointer :: dy ! Grid spacing in the y-direction + real (kind=RKIND), pointer :: scalefactor + logical :: res + + ! Return variable + integer :: ierr + + ierr = 0 + + mgr % directory = path + + ! Check to see if the index file exists in the directory + inquire(file=trim(mgr % directory)//"index", exist=res) + if (.not. res) then + call mpas_log_write("Could not find an 'index' file in geotile directory: "//trim(path), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + mgr % index = trim(mgr % directory)//"index" + + ! Create the pool for this geotile and call mpas_parse_index + call mpas_pool_create_pool(mgr % pool) + ierr = mpas_parse_index(mgr % index, mgr % pool) + if (ierr /= 0) then + call mpas_log_write("Error parsing geotile index file: "//trim(mgr % index), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + signed => null() + endian => null() + scalefactor => null() + tile_bdr => null() + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + call mpas_pool_get_config(mgr % pool, 'signed', signed) + call mpas_pool_get_config(mgr % pool, 'endian', endian) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + + ! + ! tile_bdr, signed, endian, and scale_factor all have default values, so if they + ! are not present in the index file then set them as the default values, as + ! reported in section 3-53 of the WRF-ARW User's Guide + ! + if (.not. associated(endian)) then + call mpas_pool_add_config(mgr % pool, 'endian', "big") + endif + + if (.not. associated(scalefactor)) then + call mpas_pool_add_config(mgr % pool, 'scale_factor', 1.0_RKIND) + endif + + if (.not. associated(signed)) then + call mpas_pool_add_config(mgr % pool, 'signed', 0) + endif + + if (.not. associated(tile_bdr)) then + call mpas_pool_add_config(mgr % pool, 'tile_bdr', 0) + endif + + ! + ! If this is a categorical field, then check to see if it has category_max and category_min, + ! and then set the defaults of iswater, islake, isice, isurban and isoilwater + ! + call mpas_pool_get_config(mgr % pool, 'type', fieldType) + if (fieldType == 'categorical') then + category_max => null() + category_min => null() + + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + + if (.not. associated(category_max)) then + call mpas_log_write("The index file of this categorical dataset did not contain a category_max parameter", & + messageType=MPAS_LOG_ERR) + call mpas_pool_set_error_level(err_level) ! Reset pool error level + ierr = 1 + return + endif + + if (.not. associated(category_min)) then + call mpas_log_write("The index file of this categorical dataset did not contain a category_min parameter", & + messageType=MPAS_LOG_ERR) + call mpas_pool_set_error_level(err_level) ! Reset pool error level + ierr = 1 + return + endif + + iswater => null() + islake => null() + isice => null() + isurban => null() + isoilwater => null() + + call mpas_pool_get_config(mgr % pool, 'iswater', iswater) + call mpas_pool_get_config(mgr % pool, 'islake', islake) + call mpas_pool_get_config(mgr % pool, 'isice', isice) + call mpas_pool_get_config(mgr % pool, 'isurban', isurban) + call mpas_pool_get_config(mgr % pool, 'isoilwater', isoilwater) + + if (.not. associated(iswater)) then + call mpas_pool_add_config(mgr % pool, 'iswater', 16) + endif + + if (.not. associated(islake)) then + call mpas_pool_add_config(mgr % pool, 'islake', -1) + endif + + if (.not. associated(isice)) then + call mpas_pool_add_config(mgr % pool, 'isice', 24) + endif + + if (.not. associated(isurban)) then + call mpas_pool_add_config(mgr % pool, 'isurban', 1) + endif + + if (.not. associated(isoilwater)) then + call mpas_pool_add_config(mgr % pool, 'isoilwater', 14) + endif + endif + + ! + ! Some datasets describe their z dimension as either tile_z or tile_z_start + ! and tile_z_end. mpas_parse_index will return either one or the other. However, + ! we will need a tile_z value to pass to read_geogrid and we should allocated + ! each z coordinate of a tile in Fortran to be between tile_z_start and tile_z_end. + ! + ! Currently, no static dataset that MPAS uses describes its z coordinate with a lowerbound + ! other than 1. + ! + tile_nz => null() + tile_z_start => null() + tile_z_end => null() + + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + + if (associated(tile_nz)) then + ! Here we are assuming that if tile_z is specified then tile_z_start and tile_z_end + ! are not. This is safe currently as no dataset that MPAS uses specifies both. + call mpas_pool_add_config(mgr % pool, 'tile_z_start', 1) + call mpas_pool_add_config(mgr % pool, 'tile_z_end', tile_nz) + else + call mpas_pool_add_config(mgr % pool, 'tile_z', tile_z_end - tile_z_start + 1) + end if + + + ! Reset the pool's error level + call mpas_pool_set_error_level(err_level) + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + ! Calculate the total number of pixels in x dir + ! NOTE: This calculation assumes that a dataset is a global dataset and may + ! not work correctly for non-global datasets + mgr % pixel_nx = nint(360.0_RKIND / abs(dx)) + mgr % pixel_ny = nint(180.0_RKIND / abs(dy)) + + ! Calculate the number of tiles in the x, y directions + ! NOTE: This calculation assumes that a dataset is a global dataset and may + ! not work correctly for non-global datasets + mgr % nTileX = mgr % pixel_nx / tile_nx + mgr % nTileY = mgr % pixel_ny / tile_ny + + ! Allocate hash table + allocate(mgr % hash(0: mgr % nTileX, 0: mgr % nTileY)) + + ! Mark the stack as empty + mgr % stack => null() + + end function mpas_geotile_mgr_init + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_finalize => finalize + ! + !> \brief Free all memory used by the mpas_geotile_mgr_type + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Deallocated all memory used by this geotile_mgr_type and destroy the + !> associated pool. After calling this function, none of the methods + !> should be used, unless the class is reinitialized by recalling + !> mpas_geotile_mgr_init. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_finalize(mgr) result(ierr) + + implicit none + + ! Input variable + class (mpas_geotile_mgr_type) :: mgr + + ! Return variable + integer :: ierr + + ! Local variable + integer :: i + integer :: j + + ierr = 0 + + ! Loop through the hash table and deallocate any loaded tiles + ! Then deallocate the hash table + do i = 0, mgr % nTileX + do j = 0, mgr % nTileY + if (associated(mgr % hash(i, j) % ptr)) then + if (associated(mgr % hash(i, j) % ptr % tile)) then + deallocate(mgr % hash(i, j) % ptr % tile) + endif + deallocate(mgr % hash(i, j) % ptr) + endif + enddo + enddo + deallocate(mgr % hash, stat=ierr) + + if (associated(mgr % hash) .or. (ierr /= 0)) then + call mpas_log_write("Problem deallocating the geotile hash table", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_pool_destroy_pool(mgr % pool) + if (associated(mgr % pool)) then + call mpas_log_write("Problem deallocating the geotile pool", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_stack_free(mgr % stack) + if (associated(mgr % stack)) then + call mpas_log_write("Problem deallocating the stack", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + end function mpas_geotile_mgr_finalize + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_get_tile => get_tile + ! + !> \brief Return an array containing the values of a datatile + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Retrieve the datatile that contains the coordinate lat, lon of the dataset + !> that this mpas_geotile_manager instance was initalized with. Both lat, + !> lon should be in radians and lon should be in the range of -1/2 * pi to + !> 1/2 * pi. lat values that are greater than 2.0 * pi or less than -2.0 * pi + !> will be normalized to be between -pi and pi. Upon success 0 will be returned + !> and tile will point to the mpas_geotile_type that holds the datatile which + !> contains the coordinate lat, lon. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_get_tile(mgr, lat, lon, tile) result(ierr) + implicit none + + ! Input variables + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + type (mpas_geotile_type), pointer :: tile + + ! Return variable + integer :: ierr + + ierr = 0 + tile => null() + + ! Normalize longitude to be between -pi and pi + call normalize_lon(lon) + + if (.not. mgr % search_tile(lat, lon, tile)) then + ierr = mgr % add_tile(lat, lon, tile) + endif + + end function mpas_geotile_mgr_get_tile + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_search_tile => search_tile + ! + !> \brief Search to see if a tile has already been loaded + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Private function that searches to see if the datatile that contains + !> the coordinate lat, lon has already been loaded. If the datatile has been + !> loaded, .true. will be returned and tile will point to the mpas_geotile_type + !> that contains the datatile. If the datatile has not been loaded, .false. + !> will be returned and tile will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_search_tile(mgr, lat, lon, tile) result(loaded) + + implicit none + + ! Input variables + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + type (mpas_geotile_type), pointer :: tile + + ! Return variable + logical :: loaded + + ! Local variables + integer, pointer :: tile_nx + integer, pointer :: tile_ny + character (len=StrKIND) :: fname + integer :: x, y + integer :: start_x + integer :: start_y + integer :: ierr + + loaded = .false. + tile => null() + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + + ! + ! Using gen_filename, get the tiles start x and y pixel values of the tile + ! + ierr = mgr % gen_filename(lat, lon, fname, start_x, start_y) + if (ierr /= 0) then + call mpas_log_write("Error generating filename", messageType=MPAS_LOG_ERR) + return + endif + + ! + ! Access the tile in the hash table (-1 here as the hash table is from + ! 0:tile_nx, and 0:tile_ny). + ! + x = (start_x - 1) / tile_nx + if (x < 0 .or. x > size(mgr % hash, 1)) then + return + endif + + y = (start_y - 1) / tile_ny + if (y < 0 .or. y > size(mgr % hash, 2)) then + return + endif + + tile => mgr % hash(x,y) % ptr + if (associated(tile)) then + loaded = .true. + endif + + end function mpas_geotile_mgr_search_tile + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_add_tile => add_tile + ! + !> \brief Read in a datatile file and store a reference to it + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Read the datatile that contains the coordinate lat, lon. Open success, + !> 0 will be returned and tile will point to the mpas_geotile_type which + !> contains the coordiate lat, lon. Upon success a reference to that + !> mpas_geotile_type will be placed into the hash table, which can later + !> be searched via search_tile. On error, 1 will be returned and tile + !> will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_add_tile(mgr, lat, lon, tile) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr, c_int, c_float + use mpas_c_interfacing, only : mpas_f_to_c_string + + implicit none + + interface + subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & + wordsize, status) bind(C) + use iso_c_binding, only : c_char, c_int, c_float, c_ptr + character (c_char), dimension(*), intent(in) :: fname + type (c_ptr), value :: rarray + integer (c_int), intent(in), value :: nx + integer (c_int), intent(in), value :: ny + integer (c_int), intent(in), value :: nz + integer (c_int), intent(in), value :: isigned + integer (c_int), intent(in), value :: endian + integer (c_int), intent(in), value :: wordsize + integer (c_int), intent(inout) :: status + end subroutine read_geogrid + end interface + + ! Arguments + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), intent(in) :: lat + real (kind=RKIND), intent(in) :: lon + type (mpas_geotile_type), intent(inout), pointer :: tile + integer :: ierr + + ! Local variables + integer, pointer :: tile_nx, tile_ny, tile_nz + integer, pointer :: tile_z_start, tile_z_end + integer, pointer :: tile_bdr + integer, pointer :: wordsize + integer :: start_x, start_y + integer, pointer :: signed + character (len=StrKIND), pointer :: endian + integer :: err_level + logical :: res + + character (len=StrKIND) :: fname + character (kind=c_char), dimension(StrKIND+1) :: c_fname + integer (c_int) :: c_tile_nx, c_tile_ny, c_tile_nz + integer (c_int) :: c_endian + integer (c_int) :: c_wordsize + integer (c_int) :: c_signed + integer (c_int) :: status + type (c_ptr) :: c_tile_ptr + + ierr = 0 + + tile_nx => null() + tile_ny => null() + tile_nz => null() + tile_z_start => null() + tile_z_end => null() + tile_bdr => null() + wordsize => null() + tile => null() + endian => null() + signed => null() + + err_level = mpas_pool_get_error_level() + call mpas_pool_set_error_level(MPAS_POOL_SILENT) + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'wordsize', wordsize) + call mpas_pool_get_config(mgr % pool, 'signed', signed) + call mpas_pool_get_config(mgr % pool, 'endian', endian) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + + ! Reset the pool's error level + call mpas_pool_set_error_level(err_level) + + c_tile_nx = tile_nx + 2 * tile_bdr ! The number of pixels in the x direction, including halo cells + c_tile_ny = tile_ny + 2 * tile_bdr ! The number of pixels in the y direction, including halo cells + c_tile_nz = tile_nz + + c_wordsize = wordsize + c_signed = signed + + if (endian == "big") then + c_endian = 0 + else if (endian == "little") then + c_endian = 1 + endif + + ! + ! Determine the file that contains lat, lon. + ! + ierr = mgr % gen_filename(lat, lon, fname, start_x, start_y) + if (ierr /= 0) then + call mpas_log_write("Error creating filename for coordinate: ($r, $r)", realArgs=(/lat, lon/), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + ! + ! See if this file actually exists + ! + fname = trim(mgr % directory)//trim(fname) + inquire(file=trim(fname), exist=res) + if (.not. res) then + call mpas_log_write("This geotile file does not exist: "//trim(fname), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + call mpas_f_to_c_string(fname, c_fname) + + ! + ! Allocate and read the tile + ! + allocate(tile) + allocate(tile % tile(tile_nx + (tile_bdr * 2), tile_ny + (tile_bdr * 2), tile_z_start:tile_z_end)) + c_tile_ptr = c_loc(tile % tile) + call read_geogrid(c_fname, c_tile_ptr, c_tile_nx, c_tile_ny, c_tile_nz, c_signed, c_endian, c_wordsize, status) + if (status /= 0) then + call mpas_log_write("Error reading this geogrid file: "//trim(fname), messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + + tile % fname = fname + tile % hash_x = (start_x - 1) / tile_nx + tile % hash_y = (start_y - 1) / tile_ny + tile % x = start_x + tile % y = start_y + + ! + ! Add the tile to the hash table + ! + mgr % hash(tile % hash_x, tile % hash_y) % ptr => tile + + end function mpas_geotile_mgr_add_tile + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_gen_tile_name => gen_filename + ! + !> \brief Generate the filename of the tile at lat, lon + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Generate the name of the file that contains the coordinate lat, lon + !> (in radians) and optionally return start_x and start_y (the location + !> of the first global pixel coordinate of tile). Warning: This function + !> can produce filenames that may not exist (For lon less than -.5 * pi and + !> greater than .5 * pi and lat less than -pi and greater than pi). + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_gen_tile_name(mgr, lat, lon, fname, start_x, start_y) result(ierr) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + character (len=StrKIND), intent(out) :: fname + integer, intent(out), optional :: start_x + integer, intent(out), optional :: start_y + + character (len=StrKIND), parameter :: fname_format = "(i5.5, '-', i5.5, '.', i5.5, '-', i5.5)" + + real (kind=RKIND), pointer :: dx + real (kind=RKIND), pointer :: dy + integer, pointer :: tile_nx + integer, pointer :: tile_ny + integer, dimension(2) :: x + integer, dimension(2) :: y + + integer :: ierr + ierr = 0 + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + ! Find the global pixel location that contains lat, lon + call mgr % latlon_to_pixel(lat, lon, x(1), y(1)) + + ! Calculate the range of this tile, which will be its filename + x(1) = (x(1) - modulo(x(1), tile_nx)) + 1 + x(2) = x(1) + tile_nx - 1 + + y(1) = (y(1) - modulo(y(1), tile_ny)) + 1 + y(2) = y(1) + tile_ny - 1 + + write(fname, fname_format) x(1), x(2), y(1), y(2) + + if (present(start_x)) then + start_x = x(1) + endif + if (present(start_y)) then + start_y = y(1) + endif + + end function mpas_geotile_mgr_gen_tile_name + + + !*********************************************************************** + ! + ! public subroutine mpas_geotile_mgr_tile_to_latlon => tile_to_latlon + ! + !> \brief Find the latitude, longitude location of a tile's pixels + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Given a tile, translate the pixel coordinates, i, j to a corresponding latitude + !> and longitude coordinate. + !> + !> If supersample_fac is present each pixel will be subdivided into supersample_fac ^ 2 + !> sub-pixels. If supersample_fac is greater than 1, then the calling code will need + !> to pass in supersampled i and j coordinates. + !> + !> Upon success, lat, lon will be in the range of -1/2 * pi to 1/2 * pi and 0 to + !> 2.0 * pi, respectively. + ! + !----------------------------------------------------------------------- + subroutine mpas_geotile_mgr_tile_to_latlon(mgr, tile, j, i, lat, lon, supersample_fac) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer, intent(in) :: tile + integer, value :: j + integer, value :: i + real (kind=RKIND), intent(out) :: lat + real (kind=RKIND), intent(out) :: lon + integer, optional, intent(in) :: supersample_fac + + integer, pointer :: tile_bdr + real (kind=RKIND), pointer :: known_lon + real (kind=RKIND), pointer :: known_lat + real (kind=RKIND), pointer :: dx + real (kind=RKIND), pointer :: dy + integer :: supersample_lcl + integer :: ierr + + ierr = 0 + + if (present(supersample_fac)) then + supersample_lcl = supersample_fac + else + supersample_lcl = 1 + end if + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'known_lat', known_lat) + call mpas_pool_get_config(mgr % pool, 'known_lon', known_lon) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + lat = known_lat + real(j - (supersample_lcl * tile_bdr + 1) + (supersample_lcl * (tile % y - 1)), kind=RKIND) * dy & + / supersample_lcl + lon = known_lon + real(i - (supersample_lcl * tile_bdr + 1) + (supersample_lcl * (tile % x - 1)), kind=RKIND) * dx & + / supersample_lcl + + call deg2Rad(lat) + call deg2Rad(lon) + + end subroutine mpas_geotile_mgr_tile_to_latlon + + + !*********************************************************************** + ! + ! public subroutine mpas_geotile_mgr_latlon_to_pixel => latlon_to_pixel + ! + !> \brief Translate a latitude, longitude coordinate to pixel coordinates + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Translate a latitude, longitude coordinate into global pixel coordinates. lat + !> should be in the range of -.5 * pi to .5 * pi and lon should be between -pi + !> and pi. + ! + !----------------------------------------------------------------------- + subroutine mpas_geotile_mgr_latlon_to_pixel(mgr, lat, lon, pixel_x, pixel_y) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + real (kind=RKIND), value :: lat + real (kind=RKIND), value :: lon + integer, intent(out) :: pixel_x + integer, intent(out) :: pixel_y + + integer, pointer :: tile_bdr + real (kind=RKIND), pointer :: known_lon + real (kind=RKIND), pointer :: known_lat + real, pointer :: dx + real, pointer :: dy + integer :: ierr + + ierr = 0 + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'known_lon', known_lon) + call mpas_pool_get_config(mgr % pool, 'known_lat', known_lat) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + call rad2Deg(lat) + call rad2Deg(lon) + + pixel_x = nint((lon - known_lon) / dx) + pixel_y = nint((lat - known_lat) / dy) + + if (pixel_x < 0) then + pixel_x = pixel_x + mgr % pixel_nx + else if (pixel_x >= mgr % pixel_nx) then + pixel_x = pixel_x - mgr % pixel_nx + endif + + if (pixel_y < 0) then + pixel_y = 0 + else if (pixel_y >= mgr % pixel_ny) then + pixel_y = mgr % pixel_ny - 1 + endif + + end subroutine mpas_geotile_mgr_latlon_to_pixel + + + !*********************************************************************** + ! + ! private function mpas_geotile_mgr_hash_to_latlon => hash_to_ll + ! + !> \brief Find the lat, lon center from a hash entry + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Translate the index within the hash table into the latitude and longitude + !> coordinate (in radians) of the center of the datatile at that index. + ! + !----------------------------------------------------------------------- + subroutine mpas_geotile_mgr_hash_to_latlon(mgr, xHash, yHash, lat, lon) + + implicit none + + class(mpas_geotile_mgr_type) :: mgr + integer, intent(in), value :: xHash + integer, intent(in), value :: yHash + real, intent(out) :: lat + real, intent(out) :: lon + + integer, pointer :: tile_nx + integer, pointer :: tile_ny + real (kind=RKIND), pointer :: known_lat + real (kind=RKIND), pointer :: known_lon + real (kind=RKIND), pointer :: dx + real (kind=RKIND), pointer :: dy + + integer :: x + integer :: y + + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'known_lat', known_lat) + call mpas_pool_get_config(mgr % pool, 'known_lon', known_lon) + call mpas_pool_get_config(mgr % pool, 'dx', dx) + call mpas_pool_get_config(mgr % pool, 'dy', dy) + + x = (xHash * tile_nx) + (tile_nx / 2) + y = (yHash * tile_ny) + (tile_ny / 2) + + lon = (real((x), kind=RKIND) * dx ) + known_lon + lat = (real((y), kind=RKIND) * dy ) + known_lat + + call deg2Rad(lat) + call deg2Rad(lon) + + end subroutine mpas_geotile_mgr_hash_to_latlon + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_push_neighbors => push_neighbors + ! + !> \brief Determine the tile nighbors and push them onto the stack + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Determine the neighbors of a tile and push them onto the stack. If the + !> tile neighbors have not been loaded, via add_tile, then they will be. + !> Upon success, the neighbors of a tile will be pushed onto the stack and + !> 0 will be returned. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_push_neighbors(mgr, tile) result(ierr) + + implicit none + + class(mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer, intent(in) :: tile + + integer :: ierr + type (mpas_geotile_type), pointer :: neighbor + real (kind=RKIND) :: lat + real (kind=RKIND) :: lon + integer :: xHash + integer :: yHash + + ierr = 0 + + ! Up + ! Calculate the tile's hash coordinates + neighbor => null() + if (tile % hash_y + 1 > mgr % nTileY - 1) then + xHash = modulo(tile % hash_x + (mgr % nTileX / 2), mgr % nTileX) + yHash = tile % hash_y + else + xHash = tile % hash_x + yHash = tile % hash_y + 1 + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the up tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + ! Down + neighbor => null() + if (tile % hash_y - 1 < 0) then + xHash = modulo(tile % hash_x + (mgr % nTileX / 2), mgr % nTileX) + yHash = tile % hash_y + else + xHash = tile % hash_x + yHash = tile % hash_y - 1 + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the down tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + ! Right + neighbor => null() + if (tile % hash_x + 1 > mgr % nTileX - 1) then + yHash = tile % hash_y + xHash = 0 + else + xHash = tile % hash_x + 1 + yHash = tile % hash_y + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the right tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + ! Left + neighbor => null() + if (tile % hash_x -1 < 0) then + xHash = mgr % nTileX - 1 + yHash = tile % hash_y + else + xHash = tile % hash_x - 1 + yHash = tile % hash_y + endif + call mgr % hash_to_ll(xHash, yHash, lat, lon) + + ierr = mgr % get_tile(lat, lon, neighbor) + if (ierr /= 0) then + call mpas_log_write("There was a problem getting the left tile", messageType=MPAS_LOG_ERR) + ierr = 1 + return + endif + ierr = mgr % push_tile(neighbor) + + end function mpas_geotile_mgr_push_neighbors + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!! Stack wrappers and helper functions !!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_push_tile => push_tile + ! + !> \brief Push a mpas_geotile_type onto the stack + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Wrapper subroutine for mpas_stack_push from mpas_stack.F. Aftering calling + !> this subroutine, the tile pushed will be on the top of the stack associated + !> with mpas_geotile_mgr instance (TODO: Is instance the correct term??) and pop_tile + !> can be used to retrive the tile that was last pushed onto the stack. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_push_tile(mgr, tile) result(ierr) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer :: tile + integer :: ierr + + ierr = 0 + + mgr % stack => mpas_stack_push(mgr % stack, tile) + + end function mpas_geotile_mgr_push_tile + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_pop_tile => pop_tile + ! + !> \brief Pop the top mpas_geotile_type off of the stack + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Retrieve and remove the last tile that was pushed onto the stack that + !> is associated with this mpas_geotile_mgr instance (TODO: Is instance the correct term?). If the stack is empty, + !> then tile will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_pop_tile(mgr) result(tile) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + class (mpas_stack_payload_type), pointer :: top + type (mpas_geotile_type), pointer :: tile + + tile => null() + + if (mpas_stack_is_empty(mgr % stack)) then + return + endif + + top => mpas_stack_pop(mgr % stack) + + select type(top) + type is(mpas_geotile_type) + tile => top + return + class default + ! Should not get here + end select + + end function mpas_geotile_mgr_pop_tile + + + !*********************************************************************** + ! + ! public function mpas_geotile_mgr_stack_is_empty => is_stack_empty + ! + !> \brief Return .true. if stack is empty and .false. otherwise + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Return .true. if the stack associated with this mpas_geotile_mgr instance (TODO: Is instance the correct term?) + !> is empty, and .false. if it is not empty. + ! + !----------------------------------------------------------------------- + function mpas_geotile_mgr_stack_is_empty(mgr) result(empty) + + implicit none + + class (mpas_geotile_mgr_type) :: mgr + logical :: empty + + empty = mpas_stack_is_empty(mgr % stack) + + end function mpas_geotile_mgr_stack_is_empty + + + !*********************************************************************** + ! + ! public subroutine mpas_latlon_to_xyz + ! + !> \brief Convert a latitude, longitude coordinate into its Cartesian equivalent + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Given a latitude, longitude coordinate and a radius, convert the latitude, + !> longitude coordinate into the equivalent Cartesian coordinate. + ! + !----------------------------------------------------------------------- + subroutine mpas_latlon_to_xyz(x, y, z, radius, lat, lon) + + implicit none + + real (kind=RKIND), intent(in) :: radius + real (kind=RKIND), intent(in) :: lat + real (kind=RKIND), intent(in) :: lon + real (kind=RKIND), intent(out) :: x, y, z + + z = radius * sin(lat) + x = radius * cos(lon) * cos(lat) + y = radius * sin(lon) * cos(lat) + + end subroutine mpas_latlon_to_xyz + + + ! Convert radians to degrees + subroutine rad2Deg(rad) + + implicit none + real (kind=RKIND), intent(inout) :: rad + + rad = rad * (180.0_RKIND / pii) + + end subroutine rad2Deg + + + ! Convert degrees to radians + subroutine deg2Rad(deg) + + implicit none + real (kind=RKIND), intent(inout) :: deg + + deg = deg * (pii / 180.0_RKIND) + + end subroutine deg2Rad + + + ! Normalize logitude (in radians) to be between -pi and pi. + subroutine normalize_lon(lon) + + implicit none + real (kind=RKIND), intent(inout) :: lon + + if (lon > pii) then + lon = lon - (2.0 * pii) + else if (lon < -pii) then + lon = lon + (2.0 * pii) + endif + + end subroutine normalize_lon + +end module mpas_geotile_manager diff --git a/src/core_init_atmosphere/mpas_init_atm_cases.F b/src/core_init_atmosphere/mpas_init_atm_cases.F index 2e90e5a1f7..7d43b5ee83 100644 --- a/src/core_init_atmosphere/mpas_init_atm_cases.F +++ b/src/core_init_atmosphere/mpas_init_atm_cases.F @@ -19,6 +19,7 @@ module init_atm_cases use mpas_timer use mpas_init_atm_static use mpas_init_atm_surface + use mpas_init_atm_thompson_aerosols, only: init_atm_thompson_aerosols, init_atm_thompson_aerosols_lbc use mpas_atmphys_constants, only: svpt0,svp1,svp2,svp3 use mpas_atmphys_functions use mpas_atmphys_initialize_real @@ -51,7 +52,6 @@ subroutine init_atm_setup_case(domain, stream_manager) type (MPAS_streamManager_type), intent(inout) :: stream_manager - integer :: i integer :: ierr type (block_type), pointer :: block_ptr @@ -60,43 +60,41 @@ subroutine init_atm_setup_case(domain, stream_manager) type (mpas_pool_type), pointer :: state type (mpas_pool_type), pointer :: diag type (mpas_pool_type), pointer :: diag_physics + type (mpas_pool_type), pointer :: lbc_state integer, pointer :: config_init_case logical, pointer :: config_static_interp logical, pointer :: config_native_gwd_static logical, pointer :: config_met_interp + logical, pointer :: config_blend_bdy_terrain + character (len=StrKIND), pointer :: config_start_time + character (len=StrKIND), pointer :: config_met_prefix + character (len=StrKIND), pointer :: config_specified_zeta_levels 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, start_time + type (MPAS_TimeInterval_type) :: clock_interval, lbc_stream_interval, surface_stream_interval + type (MPAS_TimeInterval_type) :: time_since_start + character(len=StrKIND) :: timeStart,timeString integer, pointer :: nCells integer, pointer :: nEdges integer, pointer :: nVertLevels - - call mpas_pool_get_config(domain % blocklist % configs, 'config_init_case', config_init_case) - - ! - ! Do some quick checks to make sure compile options are compatible with the chosen test case - ! - if (config_init_case == 6) then -#ifndef ROTATED_GRID - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('To initialize and run the mountain wave test case (case 6),', messageType=MPAS_LOG_ERR) - call mpas_log_write(' please clean and re-compile init_atmosphere with -DROTATED_GRID', messageType=MPAS_LOG_ERR) - call mpas_log_write(' added to the specification of MODEL_FORMULATION', messageType=MPAS_LOG_ERR) - call mpas_log_write(' at the top of the Makefile.', messageType=MPAS_LOG_ERR) - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_CRIT) -#endif - else -#ifdef ROTATED_GRID - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('Only test case 6 should use code compiled with -DROTATED_GRID', messageType=MPAS_LOG_ERR) - call mpas_log_write(' specified in the Makefile.', messageType=MPAS_LOG_ERR) - call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_CRIT) -#endif - end if + ! The next four variables are needed in the argument list for blend_bdy_terrain + ! with the dryrun argument set to true; accordingly, we never actually need to + ! set these pointers to fields + real (kind=RKIND), dimension(:), pointer :: latCell + real (kind=RKIND), dimension(:), pointer :: lonCell + real (kind=RKIND), dimension(:), pointer :: ter + integer, dimension(:), pointer :: bdyMaskCell + call mpas_pool_get_config(domain % blocklist % configs, 'config_init_case', config_init_case) if ((config_init_case == 1) .or. (config_init_case == 2) .or. (config_init_case == 3)) then @@ -118,7 +116,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) call mpas_log_write(' calling test case setup ') - call init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) + call init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, block_ptr % configs) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -140,7 +138,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_log_write(' calling test case setup ') - call init_atm_case_squall_line(domain % dminfo, mesh, nCells, nVertLevels, state, diag, config_init_case) + call init_atm_case_squall_line(domain % dminfo, mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -160,7 +158,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) call mpas_log_write(' calling test case setup ') - call init_atm_case_mtn_wave(domain % dminfo, mesh, nCells, nVertLevels, state, diag, block_ptr % configs, config_init_case) + call init_atm_case_mtn_wave(mesh, nCells, nVertLevels, state, diag, block_ptr % configs) call decouple_variables(mesh, nCells, nVertLevels, state, diag) call mpas_log_write(' returned from test case setup ') block_ptr => block_ptr % next @@ -177,6 +175,7 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_config(block_ptr % configs, 'config_static_interp', config_static_interp) call mpas_pool_get_config(block_ptr % configs, 'config_native_gwd_static', config_native_gwd_static) call mpas_pool_get_config(block_ptr % configs, 'config_met_interp', config_met_interp) + call mpas_pool_get_config(block_ptr % configs, 'config_blend_bdy_terrain', config_blend_bdy_terrain) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) @@ -188,21 +187,30 @@ subroutine init_atm_setup_case(domain, stream_manager) call mpas_pool_get_dimension(block_ptr % dimensions, 'nEdges', nEdges) call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) - if (config_static_interp) then - - ! - ! Without a convex mesh partition file, interpolating static fields in parallel - ! will give incorrect results. Since it is very unlikely that typical users - ! will have convex partitions, it's safer to just stop if multiple MPI tasks are - ! detected when performing the static_interp step. - ! - if (domain % dminfo % nprocs > 1) then - call mpas_log_write('****************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('Error: Interpolation of static fields does not work in parallel.', messageType=MPAS_LOG_ERR) - call mpas_log_write('Please run the static_interp step using only a single MPI task.', messageType=MPAS_LOG_ERR) - call mpas_log_write('****************************************************************', messageType=MPAS_LOG_CRIT) - end if + ! + ! Before proceeding with any other processing that takes non-trivial time (e.g., static field interpolation), + ! check that the intermediate file with terrain information exists if config_blend_bdy_terrain = true. + ! + ! NB: When calling blend_bdy_terrain(...) with the 'dryrun' argument set, the nCells, latCell, lonCell, + ! bdyMaskCell, and ter arguments are not used -- only the config_met_prefix and config_start_time + ! arguments are used. + ! + if (config_blend_bdy_terrain) then + call mpas_pool_get_config(block_ptr % configs, 'config_start_time', config_start_time) + call mpas_pool_get_config(block_ptr % configs, 'config_met_prefix', config_met_prefix) + + call blend_bdy_terrain(config_met_prefix, config_start_time, & + nCells, latCell, lonCell, bdyMaskCell, ter, .true., ierr) + if (ierr /= 0) then + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Blending of terrain along domain boundaries would fail, and', messageType=MPAS_LOG_ERR) + call mpas_log_write('config_blend_bdy_terrain = true in the namelist.init_atmosphere file.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_CRIT) + end if + end if + if (config_static_interp) then call init_atm_static(mesh, block_ptr % dimensions, block_ptr % configs) end if @@ -234,9 +242,10 @@ subroutine init_atm_setup_case(domain, stream_manager) end if call init_atm_case_gfs(block_ptr, mesh, nCells, nEdges, nVertLevels, fg, state, & - diag, diag_physics, config_init_case, block_ptr % dimensions, block_ptr % configs) + diag, diag_physics, block_ptr % dimensions, block_ptr % configs) if (config_met_interp) then + call init_atm_thompson_aerosols(block_ptr, mesh, block_ptr % configs, diag, state) call physics_initialize_real(mesh, fg, domain % dminfo, block_ptr % dimensions, block_ptr % configs) end if @@ -246,6 +255,21 @@ subroutine init_atm_setup_case(domain, stream_manager) else if (config_init_case == 8 ) then call mpas_log_write('real-data surface (SST) update test case ') + + ! + ! Check that config_fg_interval matches the output_interval of the surface stream + ! + clock_interval = mpas_get_clock_timestep(domain % clock, ierr=ierr) + surface_stream_interval = MPAS_stream_mgr_get_stream_interval(stream_manager, 'surface', MPAS_STREAM_OUTPUT, ierr) + if (clock_interval /= surface_stream_interval) then + call mpas_log_write('****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('The intermediate SST file interval specified by ''config_fg_interval''', messageType=MPAS_LOG_ERR) + call mpas_log_write('does not match the output_interval for the ''surface'' stream.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please correct the namelist.init_atmosphere and/or', messageType=MPAS_LOG_ERR) + call mpas_log_write('streams.init_atmosphere files.', messageType=MPAS_LOG_ERR) + call mpas_log_write('****************************************************************', messageType=MPAS_LOG_CRIT) + end if + block_ptr => domain % blocklist do while (associated(block_ptr)) call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) @@ -257,11 +281,110 @@ subroutine init_atm_setup_case(domain, stream_manager) block_ptr => block_ptr % next end do + else if (config_init_case == 9 ) then + + call mpas_log_write('Lateral boundary conditions case') + + ! + ! Check that the first-guess interval (which is the same as the clock timestep) + ! matches the output interval of the 'lbc' stream + ! + clock_interval = mpas_get_clock_timestep(domain % clock, ierr=ierr) + lbc_stream_interval = MPAS_stream_mgr_get_stream_interval(stream_manager, 'lbc', MPAS_STREAM_OUTPUT, ierr) + if (clock_interval /= lbc_stream_interval) then + call mpas_log_write('****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('The intermediate file interval specified by ''config_fg_interval''', messageType=MPAS_LOG_ERR) + call mpas_log_write('does not match the output_interval for the ''lbc'' stream.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please correct the namelist.init_atmosphere and/or', messageType=MPAS_LOG_ERR) + call mpas_log_write('streams.init_atmosphere files.', messageType=MPAS_LOG_ERR) + call mpas_log_write('****************************************************************', messageType=MPAS_LOG_CRIT) + end if + + 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) + + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + call mpas_pool_get_subpool(block_ptr % structs, 'fg', fg) + call mpas_pool_get_subpool(block_ptr % structs, 'state', state) + call mpas_pool_get_subpool(block_ptr % structs, 'diag', diag) + 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) + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + 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) + + call mpas_get_time(start_time, dateTimeString=timeStart) + call init_atm_thompson_aerosols_lbc(timeString, timeStart, block_ptr, mesh, diag, state, lbc_state) + + block_ptr => block_ptr % next + end do + + call mpas_stream_mgr_write(stream_manager, streamID='lbc', ierr=ierr) + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lbc', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + call mpas_advance_clock(domain % clock) + curr_time = mpas_get_clock_time(domain % clock, MPAS_NOW) + + end do + + ! + ! Ensure that no output alarms are still ringing for the 'lbc' stream after + ! we exit the time loop above; the main run routine may write out all other + ! output streams with ringing alarms. + ! + call mpas_stream_mgr_reset_alarms(stream_manager, streamID='lbc', direction=MPAS_STREAM_OUTPUT, ierr=ierr) + + else if (config_init_case == 13 ) then + + call mpas_log_write(' CAM-MPAS grid ') + + block_ptr => domain % blocklist + do while (associated(block_ptr)) + call mpas_pool_get_config(block_ptr % configs, 'config_specified_zeta_levels', config_specified_zeta_levels) + + if (len_trim(config_specified_zeta_levels) < 1) then + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Setup of CAM-MPAS grid requires a specified set of zeta levels.', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please set the namelist option config_specified_zeta_levels', messageType=MPAS_LOG_ERR) + call mpas_log_write('in the &vertical_grid namelist group.', messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + + call mpas_log_write('Errors were detected in the namelist.init_atmosphere file.', messageType=MPAS_LOG_CRIT) + end if + + call mpas_pool_get_subpool(block_ptr % structs, 'mesh', mesh) + + ! nVertLevels is used to allocate variables on the stack in init_atm_case_cam_mpas + call mpas_pool_get_dimension(block_ptr % dimensions, 'nVertLevels', nVertLevels) + + call init_atm_case_cam_mpas(stream_manager, domain % dminfo, block_ptr, & + mesh, block_ptr % dimensions, block_ptr % configs, nVertLevels) + + block_ptr => block_ptr % next + end do + else - call mpas_log_write(' ****************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write(' Only test cases 1 through 8 are currently supported.', messageType=MPAS_LOG_ERR) - call mpas_log_write(' ****************************************************', messageType=MPAS_LOG_CRIT) + call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Only test cases 1 through 9 and 13 are currently supported.', messageType=MPAS_LOG_ERR) + call mpas_log_write(' ***********************************************************', messageType=MPAS_LOG_CRIT) end if @@ -284,7 +407,7 @@ end subroutine init_atm_setup_case !---------------------------------------------------------------------------------------------------------- - subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, test_case) + subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -297,7 +420,6 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(in) :: configs - integer, intent(in) :: test_case real (kind=RKIND), parameter :: u0 = 35.0 real (kind=RKIND), parameter :: alpha_grid = 0. ! no grid rotation @@ -314,7 +436,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp real (kind=RKIND), dimension(:), pointer :: surface_pressure real (kind=RKIND), dimension(:,:), pointer :: zgrid, zxu, zz, hx - real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt + real (kind=RKIND), dimension(:,:), pointer :: ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, dss, t, rt real (kind=RKIND), dimension(:,:), pointer :: u, ru, w, rw, v real (kind=RKIND), dimension(:,:), pointer :: rho, theta real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 @@ -332,29 +454,25 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes integer, pointer :: nz1, nCellsSolve, nEdges, maxEdges, nVertices !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, verticesOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - real (kind=RKIND) :: flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r + real (kind=RKIND) :: flux, fluxk, lat1, lat2, r_pert, u_pert, lat_pert, lon_pert - real (kind=RKIND) :: ptop, p0, phi + real (kind=RKIND) :: p0, phi real (kind=RKIND) :: lon_Edge - real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str + real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, str - real (kind=RKIND) :: es, qvs, xnutr, znut, ptemp - integer :: iter - - real (kind=RKIND), dimension(nVertLevels + 1 ) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv, bn, divh, dpn + real (kind=RKIND) :: es, xnutr, znut, ptemp real (kind=RKIND), dimension(nVertLevels + 1 ) :: sh, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND), dimension(nVertLevels ) :: eta, etav, teta, ppi, tt, temperature_1d - real (kind=RKIND) :: d1, d2, d3, cof1, cof2, psurf + real (kind=RKIND) :: cof1, cof2, psurf real (kind=RKIND), pointer :: cf1, cf2, cf3 ! storage for (lat,z) arrays for zonal velocity calculation @@ -378,6 +496,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), pointer :: nominalMinDc real (kind=RKIND), dimension(:), pointer :: latCell, latVertex, lonVertex, latEdge, lonEdge real (kind=RKIND), dimension(:), pointer :: fEdge, fVertex @@ -388,11 +507,12 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes integer, pointer :: config_theta_adv_order integer, pointer :: config_init_case + character (len=StrKIND), pointer :: config_interface_projection call mpas_pool_get_config(configs, 'config_init_case', config_init_case) call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) - + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) ! ! Scale all distances and areas from a unit sphere to one with radius sphere_radius @@ -411,6 +531,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) @@ -428,6 +549,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes areaCell(:) = areaCell(:) * sphere_radius**2.0 areaTriangle(:) = areaTriangle(:) * sphere_radius**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * sphere_radius**2.0 + nominalMinDc = nominalMinDc * sphere_radius call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -574,12 +696,25 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral are supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) @@ -698,7 +833,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes !get moisture if (moisture) then - qv_2d(k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max ) + qv_2d(k,i) = env_qv( temperature_1d(k), ptemp, rh_max ) end if tt(k) = temperature_1d(k)*(1.+1.61*qv_2d(k,i)) @@ -806,7 +941,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes !get moisture if (moisture) then - !scalars(index_qv,k,i) = env_qv( ztemp, temperature_1d(k), ptemp, rh_max ) + !scalars(index_qv,k,i) = env_qv( temperature_1d(k), ptemp, rh_max ) if(ptemp < 50000.) then relhum(k,i) = 0.0 @@ -916,7 +1051,7 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes if (rebalance) then - call init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1,lat2,dvEdge(iEdge),sphere_radius,u0,nz1,nlat) + call init_atm_calc_flux_zonal(u_2d,lat_2d,flux_zonal,lat1,lat2,dvEdge(iEdge),sphere_radius,u0,nz1,nlat) do k=1,nVertLevels fluxk = u0*flux_zonal(k)/(0.5*(rb(k,iCell1)+rb(k,iCell2)+rr(k,iCell1)+rr(k,iCell2))) u(k,iEdge) = fluxk + u_pert @@ -1080,12 +1215,12 @@ subroutine init_atm_case_jw(mesh, nCells, nVertLevels, state, diag, configs, tes end subroutine init_atm_case_jw - subroutine init_atm_calc_flux_zonal(u_2d,etavs_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat) + subroutine init_atm_calc_flux_zonal(u_2d,lat_2d,flux_zonal,lat1_in,lat2_in,dvEdge,a,u0,nz1,nlat) implicit none integer, intent(in) :: nz1,nlat - real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_2d,etavs_2d + real (kind=RKIND), dimension(nz1,nlat), intent(in) :: u_2d real (kind=RKIND), dimension(nlat), intent(in) :: lat_2d real (kind=RKIND), dimension(nz1), intent(out) :: flux_zonal real (kind=RKIND), intent(in) :: lat1_in, lat2_in, dvEdge, a, u0 @@ -1230,7 +1365,7 @@ subroutine init_atm_recompute_geostrophic_wind(u_2d,rho_2d,pp_2d,qv_2d,lat_2d,zz end subroutine init_atm_recompute_geostrophic_wind - subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, diag, test_case) + subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, diag, configs, test_case) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup squall line and supercell test case !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1243,6 +1378,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d integer, intent(in) :: nVertLevels type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(in) :: configs integer, intent(in) :: test_case real (kind=RKIND), dimension(:), pointer :: rdzw, dzu, rdzu, fzm, fzp @@ -1252,46 +1388,46 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, nz1, itr, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, nz1, itr, cell1, cell2 integer, pointer :: nEdges, nVertices, maxEdges, nCellsSolve integer, pointer :: index_qv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znu, znw, znwc, znwv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: znuc, znuv - real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum, thi, tbi, cqwb - real (kind=RKIND) :: r, xnutr + real (kind=RKIND) :: xnutr real (kind=RKIND) :: ztemp, zd, zt, dz, str real (kind=RKIND), dimension(nVertLevels ) :: qvb real (kind=RKIND), dimension(nVertLevels ) :: t_init_1d - real (kind=RKIND) :: d1, d2, d3, cof1, cof2 + real (kind=RKIND) :: cof1, cof2 real (kind=RKIND), pointer :: cf1, cf2, cf3 real (kind=RKIND) :: ztr, thetar, ttr, thetas, um, us, zts, pitop, pibtop, ptopb, ptop, rcp, rcv, p0 real (kind=RKIND) :: radx, radz, zcent, xmid, delt, xloc, rad, yloc, ymid, a_scale - real (kind=RKIND) :: pres, temp, es, qvs + real (kind=RKIND) :: pres, temp, qvs real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta real (kind=RKIND), dimension(:), pointer :: u_init, qv_init, angleEdge, fEdge, fVertex + character (len=StrKIND), pointer :: config_interface_projection + call mpas_pool_get_array(mesh, 'xCell', xCell) call mpas_pool_get_array(mesh, 'yCell', yCell) call mpas_pool_get_array(mesh, 'zCell', zCell) @@ -1306,9 +1442,11 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) ! ! Scale all distances @@ -1330,6 +1468,7 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d areaCell(:) = areaCell(:) * a_scale**2.0 areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + nominalMinDc = nominalMinDc * a_scale call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -1457,12 +1596,25 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) @@ -1572,6 +1724,8 @@ subroutine init_atm_case_squall_line(dminfo, mesh, nCells, nVertLevels, state, d ! ! for reference sounding ! + qvb(:) = 0.0_RKIND + do itr=1,30 pitop = 1.-.5*dzw(1)*gravity*(1.+scalars(index_qv,1,1))/(cp*t(1,1)*zz(1,1)) @@ -1815,21 +1969,19 @@ end subroutine init_atm_case_squall_line !---------------------------------------------------------------------------------------------------------- - subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag, configs, init_case) + subroutine init_atm_case_mtn_wave(mesh, nCells, nVertLevels, state, diag, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Setup baroclinic wave test case from Jablonowski and Williamson 2008 (QJRMS) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! implicit none - type (dm_info), intent(in) :: dminfo type (mpas_pool_type), intent(inout) :: mesh integer, intent(in) :: nCells integer, intent(in) :: nVertLevels type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(inout) :: configs - integer, intent(in) :: init_case real (kind=RKIND), parameter :: t0=288., hm=250. @@ -1839,12 +1991,12 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), dimension(:,:,:), pointer :: scalars, deriv_two, zb, zb3 !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: eoe integer, dimension(:), pointer :: nEdgesOnEdge, nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, cellsOnCell real (kind=RKIND), dimension(:,:), pointer :: weightsOnEdge - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2, nz1 + integer :: iCell, iCell1, iCell2 , iEdge, ivtx, i, k, nz, itr, cell1, cell2, nz1 integer, pointer :: nEdges, maxEdges, nCellsSolve, nVertices integer, pointer :: index_qv @@ -1853,20 +2005,18 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND) :: ztemp, zd, zt, dz, str real (kind=RKIND), dimension(nVertLevels, nCells) :: relhum - real (kind=RKIND) :: es, qvs, xnutr, ptemp - integer :: iter + real (kind=RKIND) :: qvs, xnutr real (kind=RKIND), dimension(nVertLevels + 1 ) :: zc, zw, ah real (kind=RKIND), dimension(nVertLevels ) :: zu, dzw, rdzwp, rdzwm real (kind=RKIND) :: d1, d2, d3, cof1, cof2 - real (kind=RKIND) :: um, us, rcp, rcv - real (kind=RKIND) :: xmid, temp, pres, a_scale + real (kind=RKIND) :: um, vm,rcp, rcv + real (kind=RKIND) :: temp, pres, a_scale - real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, sm, dzh, dzht, dzmin, z_edge, z_edge3 + real (kind=RKIND) :: xi, xa, xc, xla, zinv, xn2, xn2m, xn2l, z_edge, z_edge3 integer, dimension(nCells, 2) :: next_cell - real (kind=RKIND), dimension(nCells) :: hxzt logical, parameter :: terrain_smooth = .false. real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell @@ -1874,6 +2024,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle real (kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real (kind=RKIND), pointer :: nominalMinDc logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius real (kind=RKIND), pointer :: config_coef_3rd_order @@ -1882,8 +2033,9 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag real (kind=RKIND), pointer :: cf1, cf2, cf3 real (kind=RKIND), dimension(:,:), pointer :: t_init, w, rw, v, rho, theta - real (kind=RKIND), dimension(:), pointer :: u_init, angleEdge, fEdge, fVertex + real (kind=RKIND), dimension(:), pointer :: u_init, v_init, angleEdge, fEdge, fVertex + character (len=StrKIND), pointer :: config_interface_projection call mpas_pool_get_array(mesh, 'xCell', xCell) call mpas_pool_get_array(mesh, 'yCell', yCell) @@ -1899,12 +2051,14 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'areaCell', areaCell) call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) call mpas_pool_get_array(mesh, 'weightsOnEdge', weightsOnEdge) call mpas_pool_get_array(mesh, 'nEdgesOnEdge', nEdgesOnEdge) @@ -1915,6 +2069,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) call mpas_pool_get_array(mesh, 't_init', t_init) call mpas_pool_get_array(mesh, 'u_init', u_init) + call mpas_pool_get_array(mesh, 'v_init', v_init) call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) call mpas_pool_get_array(mesh, 'fEdge', fEdge) call mpas_pool_get_array(mesh, 'fVertex', fVertex) @@ -1938,6 +2093,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag areaCell(:) = areaCell(:) * a_scale**2.0 areaTriangle(:) = areaTriangle(:) * a_scale**2.0 kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * a_scale**2.0 + nominalMinDc = nominalMinDc * a_scale call mpas_pool_get_dimension(mesh, 'nEdges', nEdges) @@ -2045,12 +2201,25 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? d1 = .5*dzw(1) @@ -2163,8 +2332,13 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag xn2m = 0.0000 xn2l = 0.0001 - um = 10. - us = 0. + vm = 10. + um = 0. + + do k=1,nz1 + v_init(k) = vm + u_init(k) = um + end do do i=1,nCells do k=1,nz1 @@ -2188,13 +2362,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag do k=1,nz1 ztemp = .25*( zgrid(k,cell1 )+zgrid(k+1,cell1 ) & +zgrid(k,cell2)+zgrid(k+1,cell2)) - u(k,i) = um - if(i == 1 ) u_init(k) = u(k,i) - us -#ifdef ROTATED_GRID - u(k,i) = sin(angleEdge(i)) * (u(k,i) - us) -#else - u(k,i) = cos(angleEdge(i)) * (u(k,i) - us) -#endif + u(k,i) = vm*sin(angleEdge(i)) + um*cos(angleEdge(i)) end do end if end do @@ -2443,7 +2611,7 @@ subroutine init_atm_case_mtn_wave(dminfo, mesh, nCells, nVertLevels, state, diag end subroutine init_atm_case_mtn_wave - subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, diag_physics, init_case, dims, configs) + subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, diag_physics, dims, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Real-data test case using GFS data !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2466,7 +2634,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag type (mpas_pool_type), intent(inout):: diag_physics - integer, intent(in) :: init_case type (mpas_pool_type), intent(inout):: dims type (mpas_pool_type), intent(inout):: configs @@ -2501,7 +2668,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:,:), pointer :: deriv_two real (kind=RKIND) :: target_z - integer :: iCell, iCell1, iCell2 , iEdge, vtx1, vtx2, ivtx, i, k, nz, itr, itrp, cell1, cell2 + integer :: iCell, iCell1, iCell2 , iEdge, i, k, nz, cell1, cell2 integer, pointer :: nCellsSolve, nz1 integer :: nInterpPoints, ndims @@ -2515,19 +2682,19 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state integer :: masked !This is temporary variable here. It just need when calculate tangential velocity v. - integer :: eoe, j + integer :: j integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: edgesOnEdge, cellsOnEdge, edgesOnCell, cellsOnCell real (kind=RKIND), dimension(:), pointer :: dvEdge, dcEdge, areaCell - real (kind=RKIND), dimension(:,:), pointer :: v real (kind=RKIND), dimension(:,:), pointer :: sorted_arr + integer, dimension(:), pointer :: bdyMaskCell type (field1DReal), pointer :: tempField type (field1DReal), pointer :: ter_field type (field1DReal), target :: tempFieldTarget real(kind=RKIND), dimension(:), pointer :: hs, hs1, sm0 - real(kind=RKIND) :: hm, hm_global, zh, dzmin, dzmina, dzmina_global, dzminf, dzminf_global, sm + real(kind=RKIND) :: hm, hm_global, zh, dzmin, dzmina, dzminf, dzminf_global, sm real(kind=RKIND) :: dcsum integer :: nsmterrain, kz, sfc_k logical :: hybrid, smooth @@ -2536,45 +2703,31 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND) :: p_check ! For interpolating terrain and land use - integer :: nx, ny integer :: istatus real (kind=RKIND), allocatable, dimension(:,:) :: rslab, maskslab integer, dimension(:), pointer :: mask_array integer, dimension(nEdges), target :: edge_mask - character (len=StrKIND) :: fname logical :: is_sfc_field - real (kind=RKIND) :: flux, fluxk, lat1, lat2, eta_v, r_pert, u_pert, lat_pert, lon_pert, r + real (kind=RKIND) :: flux real (kind=RKIND) :: lat, lon, x, y - real (kind=RKIND) :: ptop, p0, phi - real (kind=RKIND) :: lon_Edge - - real (kind=RKIND) :: r_earth, etavs, ztemp, zd, zt, dz, gam, delt, str + real (kind=RKIND) :: p0 - real (kind=RKIND), dimension(nVertLevels, nCells) :: rel_hum, temperature, qv - real (kind=RKIND) :: ptmp, es, rs, rgas_moist, qvs, xnutr, znut, ptemp, rcv - integer :: iter + real (kind=RKIND) :: etavs, ztemp, zd, zt, dz, str - real (kind=RKIND), dimension(nVertLevels + 1) :: hyai, hybi, znu, znw, znwc, znwv, hyam, hybm - real (kind=RKIND), dimension(nVertLevels + 1) :: znuc, znuv, bn, divh, dpn + real (kind=RKIND) :: es, rs, xnutr, znut, rcv - real (kind=RKIND), dimension(nVertLevels + 1) :: sh, zw, ah + real (kind=RKIND), dimension(:), pointer :: specified_zw + real (kind=RKIND), dimension(nVertLevels + 1) :: zw, ah real (kind=RKIND), dimension(nVertLevels) :: zu, dzw, rdzwp, rdzwm - real (kind=RKIND), dimension(nVertLevels) :: eta, etav, teta, ppi, tt - real (kind=RKIND) :: d1, d2, d3, cof1, cof2, psurf + real (kind=RKIND) :: cof1, cof2 ! storage for (lat,z) arrays for zonal velocity calculation integer, parameter :: nlat=361 - real (kind=RKIND), dimension(nVertLevels + 1) :: zz_1d, zgrid_1d, hx_1d - real (kind=RKIND), dimension(nVertLevels) :: flux_zonal - real (kind=RKIND), dimension(nlat, nVertLevels) :: u_2d, etavs_2d - real (kind=RKIND), dimension(nVertLevels + 1) :: fsum - real (kind=RKIND), dimension(nlat) :: lat_2d - real (kind=RKIND) :: dlat real (kind=RKIND) :: z_edge, z_edge3, d2fdx2_cell1, d2fdx2_cell2 real (kind=RKIND) :: alt, als, zetal, zl @@ -2590,12 +2743,14 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), pointer :: config_dzmin real (kind=RKIND), pointer :: config_ztop logical, pointer :: config_tc_vertical_grid + character (len=StrKIND), pointer :: config_specified_zeta_levels logical, pointer :: config_use_spechumd integer, pointer :: config_nfglevels integer, pointer :: config_nfgsoillevels logical, pointer :: config_smooth_surfaces integer, pointer :: config_theta_adv_order real (kind=RKIND), pointer :: config_coef_3rd_order + logical, pointer :: config_blend_bdy_terrain character (len=StrKIND), pointer :: config_extrap_airtemp integer :: extrap_airtemp @@ -2643,18 +2798,17 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state real (kind=RKIND), dimension(:,:), pointer :: sm_fg real (kind=RKIND), dimension(:), pointer :: soilz - type (hashtable) :: level_hash + type (hashtable), allocatable :: level_hash logical :: too_many_fg_levs integer :: level_value ! For outputting surface fields u10, v10, q2, rh2, and t2m from first-guess data - real (kind=RKIND), dimension(:), pointer :: u10 - real (kind=RKIND), dimension(:), pointer :: v10 real (kind=RKIND), dimension(:), pointer :: q2 real (kind=RKIND), dimension(:), pointer :: rh2 real (kind=RKIND), dimension(:), pointer :: t2m character (len=StrKIND) :: errstring + character (len=StrKIND), pointer :: config_interface_projection call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) call mpas_pool_get_config(configs, 'config_start_time', config_start_time) @@ -2665,12 +2819,15 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_pool_get_config(configs, 'config_dzmin', config_dzmin) call mpas_pool_get_config(configs, 'config_ztop', config_ztop) call mpas_pool_get_config(configs, 'config_tc_vertical_grid', config_tc_vertical_grid) + call mpas_pool_get_config(configs, 'config_specified_zeta_levels', config_specified_zeta_levels) call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) call mpas_pool_get_config(configs, 'config_nfgsoillevels', config_nfgsoillevels) call mpas_pool_get_config(configs, 'config_smooth_surfaces', config_smooth_surfaces) call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + call mpas_pool_get_config(configs, 'config_blend_bdy_terrain', config_blend_bdy_terrain) + call mpas_pool_get_config(configs, 'config_interface_projection', config_interface_projection) call mpas_pool_get_config(configs, 'config_extrap_airtemp', config_extrap_airtemp) if (trim(config_extrap_airtemp) == 'constant') then @@ -2791,102 +2948,23 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state omega_e = omega p0 = 1.e+05 - scalars(:,:,:) = 0. - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! BEGIN ADOPT GFS TERRAIN HEIGHT -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -#if 0 - call read_met_init(trim(config_met_prefix), .false., config_start_time(1:13), istatus) - - if (istatus /= 0) then - call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) - call mpas_log_write('Error opening initial meteorological data file ' & - //trim(config_met_prefix)//':'//config_start_time(1:13), messageType=MPAS_LOG_ERR) - call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) - end if - - call read_next_met_field(field, istatus) - do while (istatus == 0) - if (trim(field % field) == 'SOILHGT') then - - - call mpas_log_write('USING ECMWF TERRAIN...') - - interp_list(1) = FOUR_POINT - interp_list(2) = SEARCH - interp_list(3) = 0 - - ! - ! Set up projection - ! - call map_init(proj) - - if (field % iproj == PROJ_LATLON) then - call map_set(PROJ_LATLON, proj, & - latinc = real(field % deltalat,RKIND), & - loninc = real(field % deltalon,RKIND), & - knowni = 1.0_RKIND, & - knownj = 1.0_RKIND, & - lat1 = real(field % startlat,RKIND), & - lon1 = real(field % startlon,RKIND)) - end if - - - if (trim(field % field) == 'SOILHGT') then - nInterpPoints = nCells - latPoints => latCell - lonPoints => lonCell - destField1d => ter - ndims = 1 - end if - - allocate(rslab(-2:field % nx+3, field % ny)) - rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) - rslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny) - rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny) - rslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny) - rslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny) - rslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) - rslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) - - do i=1,nInterpPoints - lat = latPoints(i)*DEG_PER_RAD - lon = lonPoints(i)*DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - if (x < 0.5) then - lon = lon + 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - else if (x >= real(field%nx)+0.5) then - lon = lon - 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - end if - if (y < 0.5) then - y = 1.0 - else if (y >= real(field%ny)+0.5) then - y = real(field%ny) - end if - if (ndims == 1) then - destField1d(i) = interp_sequence(x, y, 1, rslab, -2, field % nx + 3, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1) - else if (ndims == 2) then - destField2d(k,i) = interp_sequence(x, y, 1, rslab, -2, field % nx + 3, 1, field % ny, 1, 1, -1.e30_RKIND, interp_list, 1) - end if - end do - deallocate(rslab) + ! + ! If requested, blend the terrain along the domain boundaries with terrain from + ! an intermediate file. For global domains, this routine will have no effect even + ! if called, since terrain is only blended for cells with bdyMaskCell > 0. + ! + if (config_blend_bdy_terrain) then + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'ter', ter) + + call blend_bdy_terrain(config_met_prefix, config_start_time, nCells, latCell, lonCell, bdyMaskCell, ter, .false., istatus) + if (istatus /= 0) then + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('* Blending of terrain along domain boundaries failed! *', messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_CRIT) end if - - deallocate(field % slab) - call read_next_met_field(field, istatus) - end do - - call read_met_close() -#endif - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! END ADOPT GFS TERRAIN HEIGHT -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + end if if (config_vertical_grid) then @@ -2907,6 +2985,14 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state hs(iCell) = 0. if(ter(iCell) .ne. 0.) then do j = 1,nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the terrain value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the terrain in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + ter(nCells+1) = ter(iCell) + end if + hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) & / dcEdge(edgesOnCell(j,iCell)) & * (ter(cellsOnCell(j,iCell))-ter(iCell)) @@ -2919,6 +3005,14 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state ter(iCell) = 0. if(hs(iCell) .ne. 0.) then do j = 1,nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the terrain value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the terrain in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + hs(nCells+1) = hs(iCell) + end if + ter(iCell) = ter(iCell) + dvEdge(edgesOnCell(j,iCell)) & / dcEdge(edgesOnCell(j,iCell)) & * (hs(cellsOnCell(j,iCell))-hs(iCell)) @@ -2943,7 +3037,37 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state ! Metrics for hybrid coordinate and vertical stretching - if (config_tc_vertical_grid) then + ! + ! If a the name of a file with vertical coordinate values has been specified, + ! use those values to setup the vertical grid + ! + if (len_trim(config_specified_zeta_levels) > 0) then + + call mpas_log_write('Setting up vertical grid using levels from '''//trim(config_specified_zeta_levels)//'''') + + if (read_text_array(dminfo, trim(config_specified_zeta_levels), specified_zw) /= 0) then + call mpas_log_write('Failed to read vertical levels from '''//trim(config_specified_zeta_levels)//'''', & + messageType=MPAS_LOG_CRIT) + end if + + if (size(specified_zw) /= nz) then + call mpas_log_write('In the namelist.init_atmosphere file, config_nvertlevels = $i, but ', intArgs=(/nz1/), & + messageType=MPAS_LOG_ERR) + call mpas_log_write('but '''//trim(config_specified_zeta_levels)//''' has $i values.', intArgs=(/size(specified_zw)/), & + messageType=MPAS_LOG_ERR) + call mpas_log_write(''''//trim(config_specified_zeta_levels)//''' must contain nVertLevels+1 ($i) values.', intArgs=(/nz/), & + messageType=MPAS_LOG_CRIT) + end if + + zw(:) = specified_zw(:) + zt = zw(nz) + + deallocate(specified_zw) + + ! + ! Otherwise, see if the user has requested to set up the vertical grid as in the MPAS TC configuration + ! + else if (config_tc_vertical_grid) then call mpas_log_write('Setting up vertical levels as in 2014 TC experiments') @@ -2989,6 +3113,9 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state if (k > 1) dzw(k-1) = zw(k)-zw(k-1) end do + ! + ! Otherwise, use the vertical level configuration from MPAS v2.0 + ! else call mpas_log_write('Setting up vertical levels as in MPAS 2.0 and earlier') @@ -3050,12 +3177,25 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state do k=2,nz1 dzu (k) = .5*(dzw(k)+dzw(k-1)) rdzu(k) = 1./dzu(k) - fzp (k) = .5* dzw(k )/dzu(k) - fzm (k) = .5* dzw(k-1)/dzu(k) rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) end do + call mpas_log_write(" interface_projection is " // trim(config_interface_projection)) + if (trim(config_interface_projection) .eq. "linear_interpolation") then + do k=2,nz1 + fzp (k) = .5* dzw(k )/dzu(k) + fzm (k) = .5* dzw(k-1)/dzu(k) + end do + else if (trim(config_interface_projection) .eq. "layer_integral") then + do k=2,nz1 + fzm (k) = .5* dzw(k )/dzu(k) + fzp (k) = .5* dzw(k-1)/dzu(k) + end do + else + call mpas_log_write('only linear_interpolation or layer_integral supported', messageType=MPAS_LOG_CRIT) + end if + !********** how are we storing cf1, cf2 and cf3? COF1 = (2.*DZU(2)+DZU(3))/(DZU(2)+DZU(3))*DZW(1)/DZU(2) @@ -3072,8 +3212,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state ! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) - call mpas_log_write(' cf1, cf2, cf3 = ', realArgs=(/cf1,cf2,cf3/)) - ! Smoothing algorithm for coordinate surfaces smooth = config_smooth_surfaces @@ -3105,19 +3243,18 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state hs1(iCell) = 0. do j = 1,nEdgesOnCell(iCell) + ! For smoothing at cells along the boundary of the mesh, set the hx value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the hx in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + hx(k,nCells+1) = hx(k,iCell) + end if + hs1(iCell) = hs1(iCell) + dvEdge(edgesOnCell(j,iCell)) & / dcEdge(edgesOnCell(j,iCell)) & * (hx(k,cellsOnCell(j,iCell))-hx(k,iCell)) end do - hs1(iCell) = hx(k,iCell) + sm*hs1(iCell) - - hs(iCell) = 0. - ! do j = 1,nEdgesOnCell(iCell) - ! hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) & - ! / dcEdge(edgesOnCell(j,iCell)) & - ! * (hs1(cellsOnCell(j,iCell))-hs1(iCell)) - ! end do - hs(iCell) = hs1(iCell) - 0.*hs(iCell) + hs(iCell) = hx(k,iCell) + sm*hs1(iCell) end do @@ -3199,6 +3336,15 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state do iEdge = 1,nEdges cell1 = cellsOnEdge(1,iEdge) cell2 = cellsOnEdge(2,iEdge) + + ! Avoid referencing the garbage cell for exterior edges + if (cell1 == nCells+1) then + cell1 = cell2 + end if + if (cell2 == nCells+1) then + cell2 = cell1 + end if + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve ) then do k = 1, nVertLevels @@ -3315,6 +3461,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_CRIT) end if + allocate(level_hash) call mpas_hash_init(level_hash) too_many_fg_levs = .false. @@ -4119,6 +4266,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state call read_met_close() level_value = mpas_hash_size(level_hash) call mpas_hash_destroy(level_hash) + deallocate(level_hash) if (too_many_fg_levs) then write(errstring,'(a,i4)') ' Please increase config_nfglevels to at least ', level_value @@ -4433,9 +4581,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state if (allocated(maskslab)) deallocate(maskslab) - ! Freeze really cold ocean - where (sst < 271.0 .and. landmask == 0) xice = 1.0 - ! Limit XICE to values between 0 and 1. Although the input meteorological field is between 0. ! and 1., interpolation to the MPAS grid can yield values of XiCE less than 0. and greater ! than 1.: @@ -4499,7 +4644,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) relhum(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) - if (target_z < z_fg(1,iCell) .and. k < nVertLevels) relhum(k,iCell) = relhum(k+1,iCell) end do @@ -4517,7 +4661,6 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) spechum(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) - if (target_z < z_fg(1,iCell) .and. k < nVertLevels) spechum(k,iCell) = spechum(k+1,iCell) end do @@ -4570,7 +4713,7 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state do k=1,nVertLevels target_z = 0.25 * (zgrid(k,cellsOnEdge(1,iEdge)) + zgrid(k+1,cellsOnEdge(1,iEdge)) + zgrid(k,cellsOnEdge(2,iEdge)) + zgrid(k+1,cellsOnEdge(2,iEdge))) ! u(k,iEdge) = vertical_interp(target_z, nfglevels_actual, sorted_arr, order=1, extrap=0) - u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) + u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) end do end do @@ -4665,6 +4808,14 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state enddo endif + ! + ! After RH has been used to compute qv (unless config_use_spechumd = T and a valid spechum field + ! is available), modify the RH field to be with respect to ice for temperatures below freezing. + ! NB: Here we pass in 1:nCells explicitly, since computations involving the "garbage cell" could + ! trigger FPEs. + ! + call convert_relhum_wrt_ice(t(:,1:nCells), relhum(:,1:nCells)) + ! ! Diagnose fields needed in initial conditions file (u, w, rho, theta) ! NB: At this point, "rho_zz" is simple dry density, and "theta_m" is regular potential temperature @@ -4686,7 +4837,8 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state t(k,iCell) = t(k,iCell) * (p0 / pressure(k,iCell)) ** (rgas / cp) ! RHO_ZZ - rho_zz(k,iCell) = pressure(k,iCell) / rgas / (p(k,iCell) * t(k,iCell)) + rho_zz(k,iCell) = pressure(k,iCell) / rgas / (p(k,iCell) * t(k,iCell) & + * (1.0 + (rvord - 1.0) * scalars(index_qv,k,iCell))) rho_zz(k,iCell) = rho_zz(k,iCell) / (1.0 + scalars(index_qv,k,iCell)) end do end do @@ -4851,27 +5003,1455 @@ subroutine init_atm_case_gfs(block, mesh, nCells, nEdges, nVertLevels, fg, state end subroutine init_atm_case_gfs - integer function nearest_edge(target_lat, target_lon, & - start_edge, & - nCells, nEdges, maxEdges, nEdgesOnCell, edgesOnCell, cellsOnEdge, latCell, lonCell, latEdge, lonEdge) + !----------------------------------------------------------------------- + ! routine init_atm_case_lbc + ! + !> \brief Computes lbc_{rho,theta,u,w,qx} fields for lateral boundary conditions + !> \author Michael Duda + !> \date 22 April 2019 + !> \details + !> This routine is similar to the init_atm_case_gfs routine in that it reads + !> atmospheric fields from "intermediate" files and horizontally and vertically + !> interpolates them to an MPAS mesh. However, rather than producing model + !> initial conditions, this routine is responsible for producing only those + !> fields that are needed as model lateral boundary conditions. + ! + !----------------------------------------------------------------------- + subroutine init_atm_case_lbc(timestamp, block, mesh, nCells, nEdges, nVertLevels, fg, state, diag, lbc_state, dims, configs) + + use mpas_dmpar, only : mpas_dmpar_min_real, mpas_dmpar_max_real + use init_atm_read_met, only : met_data, read_met_init, read_met_close, read_next_met_field + use init_atm_llxy, only : proj_info, map_init, map_set, latlon_to_ij, PROJ_LATLON, PROJ_GAUSS, DEG_PER_RAD + use init_atm_hinterp, only : interp_sequence, FOUR_POINT, SIXTEEN_POINT, W_AVERAGE4, SEARCH + use mpas_hash, only : hashtable, mpas_hash_init, mpas_hash_destroy, mpas_hash_search, mpas_hash_size, mpas_hash_insert implicit none - real (kind=RKIND), intent(in) :: target_lat, target_lon - integer, intent(in) :: start_edge - integer, intent(in) :: nCells, nEdges, maxEdges - integer, dimension(nCells), intent(in) :: nEdgesOnCell - integer, dimension(maxEdges,nCells), intent(in) :: edgesOnCell - integer, dimension(2,nEdges), intent(in) :: cellsOnEdge - real (kind=RKIND), dimension(nCells), intent(in) :: latCell, lonCell - real (kind=RKIND), dimension(nEdges), intent(in) :: latEdge, lonEdge + character(len=*), intent(in) :: timestamp + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(inout) :: mesh + integer, intent(in) :: nCells + integer, intent(in) :: nEdges + integer, intent(in) :: nVertLevels + type (mpas_pool_type), intent(inout) :: fg + type (mpas_pool_type), intent(inout) :: state + type (mpas_pool_type), intent(inout) :: diag + type (mpas_pool_type), intent(inout) :: lbc_state + type (mpas_pool_type), intent(inout):: dims + type (mpas_pool_type), intent(inout):: configs - integer :: i, cell1, cell2, iCell - integer :: iEdge - integer :: current_edge - real (kind=RKIND) :: cell1_dist, cell2_dist - real (kind=RKIND) :: current_distance, d - real (kind=RKIND) :: nearest_distance + type (dm_info), pointer :: dminfo + + real (kind=RKIND), parameter :: t0b = 250.0 + + type (met_data) :: field + type (proj_info) :: proj + + real (kind=RKIND), dimension(:), pointer :: dzu, fzm, fzp + real (kind=RKIND), dimension(:), pointer :: vert_level, latPoints, lonPoints + real (kind=RKIND), dimension(:,:), pointer :: zgrid, zz + real (kind=RKIND), dimension(:,:), pointer :: pressure, ppb, pb, rho_zz, rb, rr, tb, rtb, p, pp, t, rt + real (kind=RKIND), dimension(:), pointer :: destField1d + real (kind=RKIND), dimension(:,:), pointer :: destField2d + real (kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + real (kind=RKIND), dimension(:,:,:), pointer :: scalars + + real (kind=RKIND) :: target_z + integer :: iCell, iEdge, i, k, nVertLevelsP1 + integer, pointer :: nCellsSolve + integer :: nInterpPoints, ndims + + integer :: nfglevels_actual + integer, pointer :: index_qv + + integer, dimension(5) :: interp_list + real (kind=RKIND) :: msgval + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge, edgesOnCell + real (kind=RKIND), dimension(:,:), pointer :: sorted_arr + + integer :: sfc_k + + integer :: it + real (kind=RKIND) :: p_check + + integer :: istatus + + real (kind=RKIND), allocatable, dimension(:,:) :: rslab + + real (kind=RKIND) :: flux + real (kind=RKIND) :: lat, lon, x, y + + real (kind=RKIND) :: p0 + + real (kind=RKIND) :: etavs, ztemp + + real (kind=RKIND) :: rs, rcv + + ! calculation of the water vapor mixing ratio: + real (kind=RKIND) :: sh_max,sh_min,global_sh_max,global_sh_min + + character (len=StrKIND), pointer :: config_met_prefix + logical, pointer :: config_use_spechumd + integer, pointer :: config_nfglevels + integer, pointer :: config_theta_adv_order + real (kind=RKIND), pointer :: config_coef_3rd_order + + character (len=StrKIND), pointer :: config_extrap_airtemp + integer :: extrap_airtemp + + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge + real (kind=RKIND), dimension(:), pointer :: angleEdge + + real (kind=RKIND), dimension(:,:), pointer :: u + real (kind=RKIND), dimension(:,:), pointer :: w + real (kind=RKIND), dimension(:,:), pointer :: theta + real (kind=RKIND), dimension(:,:), pointer :: rho + real (kind=RKIND), dimension(:,:), pointer :: relhum + real (kind=RKIND), dimension(:,:), pointer :: spechum + real (kind=RKIND), dimension(:,:), pointer :: ru + real (kind=RKIND), dimension(:,:), pointer :: rw + + real (kind=RKIND), dimension(:,:), pointer :: u_fg + real (kind=RKIND), dimension(:,:), pointer :: v_fg + real (kind=RKIND), dimension(:,:), pointer :: z_fg + real (kind=RKIND), dimension(:,:), pointer :: t_fg + real (kind=RKIND), dimension(:,:), pointer :: rh_fg + real (kind=RKIND), dimension(:,:), pointer :: sh_fg + real (kind=RKIND), dimension(:,:), pointer :: p_fg + real (kind=RKIND), dimension(:), pointer :: soilz + + type (hashtable), allocatable :: level_hash + logical :: too_many_fg_levs + integer :: level_value + + character (len=StrKIND) :: errstring + + real (kind=RKIND) :: max_zgrid_local, max_zgrid_global + + + call mpas_log_write('Interpolating LBCs at time '//trim(timestamp)) + + call mpas_pool_get_config(configs, 'config_met_prefix', config_met_prefix) + call mpas_pool_get_config(configs, 'config_use_spechumd', config_use_spechumd) + call mpas_pool_get_config(configs, 'config_nfglevels', config_nfglevels) + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + call mpas_pool_get_config(configs, 'config_coef_3rd_order', config_coef_3rd_order) + + call mpas_pool_get_config(configs, 'config_extrap_airtemp', config_extrap_airtemp) + if (trim(config_extrap_airtemp) == 'constant') then + extrap_airtemp = 0 + else if (trim(config_extrap_airtemp) == 'linear') then + extrap_airtemp = 1 + else if (trim(config_extrap_airtemp) == 'lapse-rate') then + extrap_airtemp = 2 + else + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('* Invalid value for namelist variable config_extrap_airtemp *', messageType=MPAS_LOG_ERR) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_CRIT) + end if + call mpas_log_write("Using option '" // trim(config_extrap_airtemp) // "' for vertical extrapolation of temperature") + + dminfo => block % domain % dminfo + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'angleEdge', angleEdge) + + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + call mpas_pool_get_array(mesh, 'zz', zz) + + call mpas_pool_get_array(diag, 'exner_base', pb) + call mpas_pool_get_array(diag, 'rho_base', rb) + call mpas_pool_get_array(diag, 'theta_base', tb) + call mpas_pool_get_array(diag, 'rtheta_base', rtb) + call mpas_pool_get_array(diag, 'exner', p) + call mpas_pool_get_array(diag, 'pressure_base', ppb) + call mpas_pool_get_array(diag, 'pressure_p', pp) + call mpas_pool_get_array(diag, 'pressure', pressure) + call mpas_pool_get_array(diag, 'relhum', relhum) + call mpas_pool_get_array(diag, 'spechum', spechum) + call mpas_pool_get_array(diag, 'ru', ru) + call mpas_pool_get_array(diag, 'rw', rw) + + call mpas_pool_get_array(state, 'rho_zz', rho_zz) + call mpas_pool_get_array(diag, 'rho_p', rr) + call mpas_pool_get_array(state, 'theta_m', t) + call mpas_pool_get_array(diag, 'rtheta_p', rt) + call mpas_pool_get_array(lbc_state, 'lbc_scalars', scalars) + call mpas_pool_get_array(lbc_state, 'lbc_u', u) + call mpas_pool_get_array(lbc_state, 'lbc_w', w) + call mpas_pool_get_array(lbc_state, 'lbc_theta', theta) + call mpas_pool_get_array(lbc_state, 'lbc_rho', rho) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'lonEdge', lonEdge) + + call mpas_pool_get_array(fg, 'u', u_fg) + call mpas_pool_get_array(fg, 'v', v_fg) + call mpas_pool_get_array(fg, 'z', z_fg) + call mpas_pool_get_array(fg, 't', t_fg) + call mpas_pool_get_array(fg, 'rh', rh_fg) + call mpas_pool_get_array(fg, 'sh', sh_fg) + call mpas_pool_get_array(fg, 'p', p_fg) + + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + nVertLevelsP1 = nVertLevels + 1 + + call mpas_pool_get_dimension(state, 'index_qv', index_qv) + + etavs = (1.0_RKIND - 0.252_RKIND) * pii / 2.0_RKIND + rcv = rgas / (cp - rgas) + p0 = 1.0e+05_RKIND + + scalars(:,:,:) = 0.0_RKIND + + ! + ! Check that we have what looks like a valid zgrid field. If the max value for zgrid is zero, + ! the input file likely does not contain vertical grid information. + ! + max_zgrid_local = maxval(zgrid(:,1:nCellsSolve)) + call mpas_dmpar_max_real(dminfo, max_zgrid_local, max_zgrid_global) + if (max_zgrid_global == 0.0_RKIND) then + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('The maximum value of the zgrid field is 0. Please ensure that the ''input'' stream ', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('contains valid vertical grid information.', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Horizontally interpolate meteorological data + ! + allocate(vert_level(config_nfglevels)) + vert_level(:) = -1.0 + + ! TODO: We should check that timestamp is actually of length >= 13 + call read_met_init(trim(config_met_prefix), .false., timestamp(1:13), istatus) + + if (istatus /= 0) then + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Error opening initial meteorological data file '//trim(config_met_prefix)//':'//timestamp(1:13), & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_CRIT) + end if + + allocate(level_hash) + call mpas_hash_init(level_hash) + too_many_fg_levs = .false. + + call read_next_met_field(field, istatus) + + do while (istatus == 0) + + interp_list(1) = FOUR_POINT + interp_list(2) = SEARCH + interp_list(3) = 0 + + msgval = -1.e30 + + if (trim(field % field) == 'UU' .or. & + trim(field % field) == 'VV' .or. & + trim(field % field) == 'TT' .or. & + trim(field % field) == 'RH' .or. & + trim(field % field) == 'SPECHUMD' .or. & + trim(field % field) == 'GHT' .or. & + trim(field % field) == 'SOILHGT' .or. & + trim(field % field) == 'PRES' .or. & + trim(field % field) == 'PRESSURE') then + + if (trim(field % field) /= 'SOILHGT') then + + ! Since the hash table can only store integers, transfer the bit pattern from + ! the real-valued xlvl into an integer; that the result is not an integer version + ! of the level is not important, since we only want to test uniqueness of levels + level_value = transfer(field % xlvl, level_value) + if (.not. mpas_hash_search(level_hash, level_value)) then + call mpas_hash_insert(level_hash, level_value) + if (mpas_hash_size(level_hash) > config_nfglevels) then + too_many_fg_levs = .true. + end if + end if + + ! + ! In case we have more than config_nfglevels levels, just keep cycling through + ! the remaining fields in the intermediate file for the purpose of counting how + ! many unique levels are found using the code above + ! + if (too_many_fg_levs) then + call read_next_met_field(field, istatus) + cycle + end if + + do k=1,config_nfglevels + if (vert_level(k) == field % xlvl .or. vert_level(k) == -1.0) exit + end do + if (vert_level(k) == -1.0) vert_level(k) = field % xlvl + else + k = 1 + end if + + ! + ! Set up projection + ! + call map_init(proj) + + if (field % iproj == PROJ_LATLON) then + call map_set(PROJ_LATLON, proj, & + latinc = real(field % deltalat,RKIND), & + loninc = real(field % deltalon,RKIND), & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) + else if (field % iproj == PROJ_GAUSS) then + call map_set(PROJ_GAUSS, proj, & + nlat = nint(field % deltalat), & + loninc = 360.0_RKIND / real(field % nx,RKIND), & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) + end if + + + ! + ! Horizontally interpolate the field at level k + ! + if (trim(field % field) == 'UU') then + call mpas_log_write('Interpolating U at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nEdges + latPoints => latEdge + lonPoints => lonEdge + call mpas_pool_get_array(fg, 'u', destField2d) + ndims = 2 + else if (trim(field % field) == 'VV') then + call mpas_log_write('Interpolating V at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nEdges + latPoints => latEdge + lonPoints => lonEdge + call mpas_pool_get_array(fg, 'v', destField2d) + ndims = 2 + else if (trim(field % field) == 'TT') then + call mpas_log_write('Interpolating TT at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 't', destField2d) + ndims = 2 + else if (trim(field % field) == 'RH') then + call mpas_log_write('Interpolating RH at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'rh', destField2d) + ndims = 2 + else if (trim(field % field) == 'SPECHUMD') then + call mpas_log_write('Interpolating SPECHUMD at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'sh', destField2d) + ndims = 2 + else if (trim(field % field) == 'GHT') then + call mpas_log_write('Interpolating GHT at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'z', destField2d) + ndims = 2 + else if (trim(field % field) == 'PRES') then + call mpas_log_write('Interpolating PRES at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'p', destField2d) + ndims = 2 + else if (trim(field % field) == 'PRESSURE') then + call mpas_log_write('Interpolating PRESSURE at $i $r', intArgs=(/k/), realArgs=(/vert_level(k)/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'p', destField2d) + ndims = 2 + else if (trim(field % field) == 'SOILHGT') then + call mpas_log_write('Interpolating SOILHGT') + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(fg, 'soilz', destField1d) + ndims = 1 + end if + + allocate(rslab(-2:field % nx+3, field % ny)) + rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) + rslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny) + rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny) + rslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny) + rslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny) + rslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) + rslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) + + do i=1,nInterpPoints + lat = latPoints(i)*DEG_PER_RAD + lon = lonPoints(i)*DEG_PER_RAD + call latlon_to_ij(proj, lat, lon, x, y) + if (x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= real(field%nx)+0.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 0.5) then + y = 1.0 + else if (y >= real(field%ny)+0.5) then + y = real(field%ny) + end if + if (ndims == 1) then + destField1d(i) = interp_sequence(x, y, 1, rslab, -2, field%nx + 3, 1, field%ny, 1, 1, msgval, interp_list, 1) + else if (ndims == 2) then + destField2d(k,i) = interp_sequence(x, y, 1, rslab, -2, field%nx + 3, 1, field%ny, 1, 1, msgval, interp_list, 1) + end if + end do + + deallocate(rslab) + + end if + + deallocate(field % slab) + call read_next_met_field(field, istatus) + end do + + call read_met_close() + level_value = mpas_hash_size(level_hash) + call mpas_hash_destroy(level_hash) + deallocate(level_hash) + + if (too_many_fg_levs) then + write(errstring,'(a,i4)') ' Please increase config_nfglevels to at least ', level_value + call mpas_log_write('*******************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Error: The meteorological data file has more than config_nfglevels.', messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(errstring), messageType=MPAS_LOG_ERR) + call mpas_log_write(' in the namelist and re-run.', messageType=MPAS_LOG_ERR) + call mpas_log_write('*******************************************************************', messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Check how many distinct levels we actually found in the meteorological data + ! + do k=1,config_nfglevels + if (vert_level(k) == -1.0) exit + end do + nfglevels_actual = k-1 + call mpas_log_write('*************************************************') + call mpas_log_write('Found $i levels in the first-guess data', intArgs=(/nfglevels_actual/)) + call mpas_log_write('*************************************************') + + + ! + ! For isobaric data, fill in the 3-d pressure field; otherwise, ensure + ! that the surface pressure and height fields are filled in + ! + if (minval(p_fg(1:nfglevels_actual,1:nCellsSolve)) == 0.0 .and. & + maxval(p_fg(1:nfglevels_actual,1:nCellsSolve)) == 0.0) then + call mpas_log_write('Setting pressure field for isobaric data') + do k=1,config_nfglevels + if (vert_level(k) /= 200100.0) then + p_fg(k,:) = vert_level(k) + end if + end do + else + call mpas_pool_get_array(fg, 'z', z_fg) + call mpas_pool_get_array(fg, 'soilz', soilz) + call mpas_log_write('Assuming model-level input data') + do k=1,config_nfglevels + if (vert_level(k) == 200100.0) then + z_fg(k,:) = soilz(:) + end if + end do + end if + + + ! + ! Compute normal wind component and store in fg % u + ! + do iEdge=1,nEdges + do k=1,nfglevels_actual + u_fg(k,iEdge) = cos(angleEdge(iEdge)) * u_fg(k,iEdge) & + + sin(angleEdge(iEdge)) * v_fg(k,iEdge) + end do + end do + + ! + ! Vertically interpolate meteorological data + ! + allocate(sorted_arr(2,nfglevels_actual)) + + do iCell=1,nCells + + ! T + sorted_arr(:,:) = -999.0 + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = t_fg(k,iCell) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = 1, nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + t(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, & + extrap=extrap_airtemp, ierr=istatus) + if (istatus /= 0) then + write(errstring,'(a,i4,a,i10)') 'Error in interpolation of t(k,iCell) for k=', k, ', iCell=', iCell + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(errstring), messageType=MPAS_LOG_ERR) + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_CRIT) + end if + end do + + + ! RH + sorted_arr(:,:) = -999.0 + relhum(:,iCell) = 0._RKIND + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = rh_fg(k,iCell) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = nVertLevels, 1, -1 + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + relhum(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) + if (target_z < z_fg(1,iCell) .and. k < nVertLevels) relhum(k,iCell) = relhum(k+1,iCell) + end do + + + ! SPECHUM: if first-guess values are negative, set those values to zero before + ! vertical interpolation. + sorted_arr(:,:) = -999.0 + spechum(:,iCell) = 0._RKIND + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = max(0._RKIND,sh_fg(k,iCell)) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = nVertLevels, 1, -1 + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + spechum(k,iCell) = vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=0) + if (target_z < z_fg(1,iCell) .and. k < nVertLevels) spechum(k,iCell) = spechum(k+1,iCell) + end do + + + ! PRESSURE + sorted_arr(:,:) = -999.0 + do k = 1, nfglevels_actual + sorted_arr(1,k) = z_fg(k,iCell) + if (vert_level(k) == 200100.0) then + sorted_arr(1,k) = 99999.0 + sfc_k = k + p_fg(k,iCell) = 1.0 ! Any value that has valid log is fine... + end if + sorted_arr(2,k) = log(p_fg(k,iCell)) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k = 1, nVertLevels + target_z = 0.5 * (zgrid(k,iCell) + zgrid(k+1,iCell)) + pressure(k,iCell) = exp(vertical_interp(target_z, nfglevels_actual-1, & + sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1)) + end do + + end do + + + do iEdge=1,nEdges + + ! U + sorted_arr(:,:) = -999.0 + do k=1,nfglevels_actual + sorted_arr(1,k) = 0.5 * (z_fg(k,cellsOnEdge(1,iEdge)) + z_fg(k,cellsOnEdge(2,iEdge))) + if (vert_level(k) == 200100.0) sorted_arr(1,k) = 99999.0 + sorted_arr(2,k) = u_fg(k,iEdge) + end do + call mpas_quicksort(nfglevels_actual, sorted_arr) + do k=1,nVertLevels + target_z = 0.25 * (zgrid(k,cellsOnEdge(1,iEdge)) + zgrid(k+1,cellsOnEdge(1,iEdge)) & + + zgrid(k,cellsOnEdge(2,iEdge)) + zgrid(k+1,cellsOnEdge(2,iEdge))) + u(k,iEdge) = vertical_interp(target_z, nfglevels_actual-1, sorted_arr(:,1:nfglevels_actual-1), order=1, extrap=1) + end do + + end do + + deallocate(sorted_arr) + + + ! Diagnose the water vapor mixing ratios: + global_sh_min = 0._RKIND + global_sh_max = 0._RKIND + if(config_use_spechumd) then + sh_min = minval(spechum(:,1:nCellsSolve)) + sh_max = maxval(spechum(:,1:nCellsSolve)) + call mpas_dmpar_min_real(dminfo,sh_min,global_sh_min) + call mpas_dmpar_max_real(dminfo,sh_max,global_sh_max) + endif + call mpas_log_write('') + call mpas_log_write('--- global_sh_min = $r', realArgs=(/global_sh_min/)) + call mpas_log_write('--- global_sh_max = $r', realArgs=(/global_sh_max/)) + call mpas_log_write('') + + call mpas_log_write('--- config_use_spechumd = $l', logicArgs=(/config_use_spechumd/)) + if(.not. config_use_spechumd .or. (global_sh_min==0._RKIND .and. global_sh_max==0._RKIND)) then + !--- calculate the saturation mixing ratio and interpolated first-guess relative humidity: + if (config_use_spechumd) then + call mpas_log_write('config_use_spechumd=T, but specific humidity was not found in ' & + //trim(config_met_prefix)//':'//timestamp(1:13), messageType=MPAS_LOG_WARN) + end if + call mpas_log_write(' *** initializing water vapor mixing ratio using first-guess relative humidity') + call mpas_log_write('') + + do k = 1, nVertLevels + do iCell = 1, nCells + ! + ! Note: the RH field provided by ungrib should always be with respect to liquid water, + ! hence, we can always call rslf; see the routine fix_gfs_rh in WPS/ungrib/src/rrpr.F . + ! + rs = rslf(pressure(k,iCell),t(k,iCell)) + scalars(index_qv,k,iCell) = 0.01_RKIND*rs*relhum(k,iCell) + enddo + enddo + else + !--- use the interpolated first-guess specific humidity: + call mpas_log_write(' *** initializing water vapor mixing ratio using first-guess specific humidity') + call mpas_log_write('') + do k = 1, nVertLevels + do iCell = 1, nCells + scalars(index_qv,k,iCell) = spechum(k,iCell)/(1._RKIND-spechum(k,iCell)) + enddo + enddo + endif + + ! + ! Diagnose fields needed in initial conditions file (u, w, rho, theta) + ! NB: At this point, "rho_zz" is simple dry density, and "theta_m" is regular potential temperature + ! + do iCell=1,nCells + + do k=1,nVertLevels + ! PI + p(k,iCell) = (pressure(k,iCell) / p0) ** (rgas / cp) + + ! THETA - can compute this using PI instead + t(k,iCell) = t(k,iCell) * (p0 / pressure(k,iCell)) ** (rgas / cp) + + ! RHO_ZZ + rho_zz(k,iCell) = pressure(k,iCell) / rgas / (p(k,iCell) * t(k,iCell)) + rho_zz(k,iCell) = rho_zz(k,iCell) / (1.0 + scalars(index_qv,k,iCell)) + end do + end do + + + ! + ! Reference state based on a dry isothermal atmosphere + ! + do iCell=1,nCells + do k=1,nVertLevels + ztemp = 0.5*(zgrid(k+1,iCell)+zgrid(k,iCell)) + ppb(k,iCell) = p0*exp(-gravity*ztemp/(rgas*t0b)) ! pressure_base + pb (k,iCell) = (ppb(k,iCell)/p0)**(rgas/cp) ! exner_base + rb (k,iCell) = ppb(k,iCell)/(rgas*t0b) ! rho_base + tb (k,iCell) = t0b/pb(k,iCell) ! theta_base + rtb(k,iCell) = rb(k,iCell)*tb(k,iCell) ! rtheta_base + p (k,iCell) = pb(k,iCell) ! exner + pp (k,iCell) = 0. ! pressure_p + rr (k,iCell) = 0. ! rho_p + end do + end do + + do iCell=1,nCells + do k=1,nVertLevels + + ! couple with vertical metric + rb(k,iCell) = rb(k,iCell) / zz(k,iCell) + rho_zz(k,iCell) = rho_zz(k,iCell) / zz(k,iCell) + + pp(k,iCell) = pressure(k,iCell) - ppb(k,iCell) + rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) + + end do + end do + + do iCell=1,nCells + k = 1 + + ! couple with vertical metric, note: rr is coupled here + rho_zz(k,iCell) = ((pressure(k,iCell) / p0)**(cv / cp)) * (p0 / rgas) & + / (t(k,iCell)*(1.0 + 1.61*scalars(index_qv,k,iCell))) / zz(k,iCell) + rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) + + do k=2,nVertLevels + it = 0 + p_check = 2.0 * 0.0001 + do while ( (it < 30) .and. (p_check > 0.0001) ) + + p_check = pp(k,iCell) + + ! MPAS hydrostatic relation + pp(k,iCell) = pp(k-1,iCell) - (fzm(k)*rr(k,iCell) + fzp(k)*rr(k-1,iCell))*gravity*dzu(k) & + - (fzm(k)*rho_zz(k,iCell)*scalars(index_qv,k,iCell) & + + fzp(k)*rho_zz(k-1,iCell)*scalars(index_qv,k-1,iCell))*gravity*dzu(k) + pressure(k,iCell) = pp(k,iCell) + ppb(k,iCell) + p(k,iCell) = (pressure(k,iCell) / p0) ** (rgas / cp) + + ! couple with vertical metric + rho_zz(k,iCell) = pressure(k,iCell) / rgas & + / (p(k,iCell)*t(k,iCell)*(1.0 + 1.61*scalars(index_qv,k,iCell)))/zz(k,iCell) + rr(k,iCell) = rho_zz(k,iCell) - rb(k,iCell) + + p_check = abs(p_check - pp(k,iCell)) + + it = it + 1 + end do + end do + end do + + ! Compute theta_m and rho-tilde + do iCell=1,nCells + do k=1,nVertLevels + t(k,iCell) = t(k,iCell) * (1.0 + 1.61*scalars(index_qv,k,iCell)) + rr(k,iCell) = rr(k,iCell)*zz(k,iCell) + end do + end do + + do iEdge=1,nEdges + do k=1,nVertLevels + ru(k,iEdge) = u(k,iEdge) * 0.5*(rho_zz(k,cellsOnEdge(1,iEdge)) + rho_zz(k,cellsOnEdge(2,iEdge))) + end do + end do + + + rw(:,:) = 0.0 + + do iCell=1,nCellsSolve + + do i=1,nEdgesOnCell(iCell) + iEdge=edgesOnCell(i,iCell) + + do k = 2, nVertLevels + flux = (fzm(k)*ru(k,iEdge)+fzp(k)*ru(k-1,iEdge)) + if (iCell == cellsOnEdge(1,iEdge)) then + rw(k,iCell) = rw(k,iCell) - (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb(k,1,iEdge)*flux + else + rw(k,iCell) = rw(k,iCell) + (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb(k,2,iEdge)*flux + end if + + if (config_theta_adv_order ==3) then + if (iCell == cellsOnEdge(1,iEdge)) then + rw(k,iCell) = rw(k,iCell) & + + sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* & + (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb3(k,1,iEdge)*flux + else + rw(k,iCell) = rw(k,iCell) & + - sign(1.0_RKIND,ru(k,iEdge))*config_coef_3rd_order* & + (fzm(k)*zz(k,iCell)+fzp(k)*zz(k-1,iCell))*zb3(k,2,iEdge)*flux + end if + end if + + end do + + end do + + end do + + + ! Compute w from rho_zz and rw + do iCell=1,nCellsSolve + do k=2,nVertLevels + w(k,iCell) = rw(k,iCell) / (fzp(k) * rho_zz(k-1,iCell) + fzm(k) * rho_zz(k,iCell)) + end do + end do + + deallocate(vert_level) + + + ! Compute rho and theta from rho_zz and theta_m + do iCell=1,nCells + do k=1,nVertLevels + rho(k,iCell) = rho_zz(k,iCell) * zz(k,iCell) + theta(k,iCell) = t(k,iCell) / (1.0 + 1.61 * scalars(index_qv,k,iCell)) + end do + end do + + end subroutine init_atm_case_lbc + + + !----------------------------------------------------------------------- + ! routine init_atm_case_cam_mpas + ! + !> \brief Generate a 3-d grid for use with CAM-MPAS + !> \author Michael Duda + !> \date 20 October 2020 + !> \details + !> Given a unit-sphere SCVT, this initialization case produces an earth-radius + !> mesh with a vertical grid suitable for use with CAM-MPAS. + !> + !> The config_specified_zeta_levels must be set to the name of a text file with + !> zeta levels, the number of which must be one more than config_nvertlevels. + !> + !> Optionally, a mutable stream named 'cam_topo' may also be defined with + !> a single field, PHIS, that provides the surface geopotential to be used in + !> generating the vertical grid. + !> + !> Namelist options used by this routine: + !> * config_specified_zeta_levels + !> * config_nsmterrain + !> * config_nsm + !> * config_smooth_surfaces + !> * config_smooth_dzmin + !> * config_smooth_theta_adv_order + ! + !----------------------------------------------------------------------- + subroutine init_atm_case_cam_mpas(stream_manager, dminfo, block, mesh, & + dims, configs, nVertLevels) + + use mpas_dmpar, only : mpas_dmpar_exch_halo_field, mpas_dmpar_min_real, mpas_dmpar_max_real + use mpas_stream_manager, only : MPAS_stream_mgr_stream_exists, MPAS_stream_mgr_read + use mpas_derived_types, only : MPAS_STREAM_MGR_NOERR + + implicit none + + ! + ! Arguments + ! + type (MPAS_streamManager_type), intent(inout) :: stream_manager + type (dm_info), intent(inout) :: dminfo + type (block_type), intent(inout), target :: block + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(inout):: dims + type (mpas_pool_type), intent(inout):: configs + integer, intent(in) :: nVertLevels + + + ! + ! Local variables + ! + integer :: i, j, k + integer :: iCell, iEdge, iVtx + integer :: ierr + + integer, pointer :: nCells + integer, pointer :: nEdges + integer, pointer :: nCellsSolve + integer, pointer :: nVertices + integer, pointer :: maxEdges + + character (len=StrKIND), pointer :: config_specified_zeta_levels + + real(kind=RKIND), dimension(:), pointer :: specified_zw + + logical, pointer :: on_a_sphere + real(kind=RKIND), pointer :: sphere_radius + + real(kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real(kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge + real(kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real(kind=RKIND), dimension(:), pointer :: dcEdge, dvEdge, areaCell, areaTriangle + real(kind=RKIND), dimension(:,:), pointer :: kiteAreasOnVertex + real(kind=RKIND), pointer :: nominalMinDc + + real(kind=RKIND), dimension(:), pointer :: fEdge, fVertex + real(kind=RKIND), dimension(:), pointer :: latEdge + real(kind=RKIND), dimension(:), pointer :: latVertex + + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + integer, dimension(:,:), pointer :: edgesOnCell + + real(kind=RKIND), dimension(:), pointer :: PHIS + real(kind=RKIND), dimension(:), pointer :: ter + real(kind=RKIND) :: min_ter, max_ter + type (field1DReal), pointer :: ter_field + + real(kind=RKIND), dimension(:), pointer :: hs, hs1 + integer, pointer :: config_nsmterrain + integer :: nsmterrain + + logical :: hybrid + integer :: kz + real(kind=RKIND), dimension(nVertLevels+1) :: zw, ah + real (kind=RKIND), dimension(nVertLevels) :: zu, dzw, rdzwp, rdzwm + real(kind=RKIND), dimension(:,:), pointer :: zgrid + real(kind=RKIND), dimension(:), pointer :: rdzw + real(kind=RKIND), dimension(:), pointer :: dzu + real(kind=RKIND), dimension(:), pointer :: rdzu + real(kind=RKIND), dimension(:), pointer :: fzm + real(kind=RKIND), dimension(:), pointer :: fzp + real(kind=RKIND), dimension(:,:), pointer :: zxu + real(kind=RKIND), dimension(:,:), pointer :: zz + + real(kind=RKIND) :: zh, zt + + real(kind=RKIND), dimension(:,:), pointer :: hx + + real(kind=RKIND) :: cof1, cof2 + real(kind=RKIND), pointer :: cf1, cf2, cf3 + + logical, pointer :: config_smooth_surfaces + integer, pointer :: config_nsm + real(kind=RKIND), pointer :: config_dzmin + + real(kind=RKIND) :: dzmin, dzmina, dzminf, dzminf_global, sm + real(kind=RKIND), dimension(:), pointer :: sm0 + real(kind=RKIND) :: dcsum + + type (field1DReal), pointer :: tempField + type (field1DReal), target :: tempFieldTarget + + integer :: cell1, cell2 + + integer, pointer :: config_theta_adv_order + real(kind=RKIND) :: z_edge, z_edge3 + real(kind=RKIND) :: d2fdx2_cell1, d2fdx2_cell2 + real(kind=RKIND), dimension(:,:,:), pointer :: deriv_two + real(kind=RKIND), dimension(:,:,:), pointer :: zb, zb3 + + + ! + ! Get dimensions + ! + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nEdges', nEdges) + call mpas_pool_get_dimension(dims, 'nVertices', nVertices) + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + + + ! + ! Scale all distances and areas from a unit sphere to one with radius sphere_radius + ! + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xEdge', xEdge) + call mpas_pool_get_array(mesh, 'yEdge', yEdge) + call mpas_pool_get_array(mesh, 'zEdge', zEdge) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'dvEdge', dvEdge) + call mpas_pool_get_array(mesh, 'dcEdge', dcEdge) + call mpas_pool_get_array(mesh, 'areaCell', areaCell) + call mpas_pool_get_array(mesh, 'areaTriangle', areaTriangle) + call mpas_pool_get_array(mesh, 'kiteAreasOnVertex', kiteAreasOnVertex) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + call mpas_pool_get_config(mesh, 'on_a_sphere', on_a_sphere) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + xCell(:) = xCell(:) * sphere_radius + yCell(:) = yCell(:) * sphere_radius + zCell(:) = zCell(:) * sphere_radius + xVertex(:) = xVertex(:) * sphere_radius + yVertex(:) = yVertex(:) * sphere_radius + zVertex(:) = zVertex(:) * sphere_radius + xEdge(:) = xEdge(:) * sphere_radius + yEdge(:) = yEdge(:) * sphere_radius + zEdge(:) = zEdge(:) * sphere_radius + dvEdge(:) = dvEdge(:) * sphere_radius + dcEdge(:) = dcEdge(:) * sphere_radius + areaCell(:) = areaCell(:) * sphere_radius**2 + areaTriangle(:) = areaTriangle(:) * sphere_radius**2 + kiteAreasOnVertex(:,:) = kiteAreasOnVertex(:,:) * sphere_radius**2 + nominalMinDc = nominalMinDc * sphere_radius + + + ! + ! Initialize Coriolis parameter field on edges and vertices + ! + call mpas_pool_get_array(mesh, 'fEdge', fEdge) + call mpas_pool_get_array(mesh, 'fVertex', fVertex) + call mpas_pool_get_array(mesh, 'latEdge', latEdge) + call mpas_pool_get_array(mesh, 'latVertex', latVertex) + + do iEdge=1,nEdges + fEdge(iEdge) = 2.0 * omega * sin(latEdge(iEdge)) + end do + do iVtx=1,nVertices + fVertex(iVtx) = 2.0 * omega * sin(latVertex(iVtx)) + end do + + + ! + ! Compute weights used in advection and deformation calculation + ! + call atm_initialize_advection_rk(mesh, nCells, nEdges, maxEdges, on_a_sphere, sphere_radius) + call atm_initialize_deformation_weights(mesh, nCells, on_a_sphere, sphere_radius) + + + ! + ! Read PHIS field from cam_topo stream + ! + if (MPAS_stream_mgr_stream_exists(stream_manager, 'cam_topo')) then + call MPAS_stream_mgr_read(stream_manager, 'cam_topo', rightNow=.true., whence=MPAS_STREAM_NEAREST, ierr=ierr) + if (ierr /= MPAS_STREAM_MGR_NOERR) then + call mpas_log_write('Error reading the ''cam_topo'' stream.', messageType=MPAS_LOG_CRIT) + end if + else + call mpas_log_write('') + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_WARN) + call mpas_log_write('No ''cam_topo'' input stream with a PHIS field was defined.', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('The terrain field will be set to zero everywhere. To specify', messageType=MPAS_LOG_WARN) + call mpas_log_write('a non-zero terrain field, define a ''cam_topo'' stream, e.g.,', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write(' ', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('', messageType=MPAS_LOG_WARN) + call mpas_log_write('*************************************************************', messageType=MPAS_LOG_WARN) + call mpas_log_write('') + end if + + + ! + ! Set terrain field based on PHIS + ! + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_array(mesh, 'PHIS', PHIS) + + ter(:) = PHIS(:) / gravity + + call mpas_dmpar_min_real(dminfo, minval(ter(1:nCellsSolve)), min_ter) + call mpas_dmpar_max_real(dminfo, maxval(ter(1:nCellsSolve)), max_ter) + call mpas_log_write('') + call mpas_log_write('Terrain min/max = $r / $r', realArgs=[min_ter, max_ter]) + call mpas_log_write('') + + + ! + ! Read zeta levels from a text file + ! + call mpas_pool_get_config(configs, 'config_specified_zeta_levels', config_specified_zeta_levels) + + call mpas_log_write('Setting up vertical grid using levels from '''//trim(config_specified_zeta_levels)//'''') + + if (read_text_array(dminfo, trim(config_specified_zeta_levels), specified_zw) /= 0) then + call mpas_log_write('Failed to read vertical levels from '''//trim(config_specified_zeta_levels)//'''', & + messageType=MPAS_LOG_CRIT) + end if + + if (size(specified_zw) /= nVertLevels+1) then + call mpas_log_write('In the namelist.init_atmosphere file, config_nvertlevels = $i, ', & + intArgs=(/nVertLevels/), & + messageType=MPAS_LOG_ERR) + call mpas_log_write('but '''//trim(config_specified_zeta_levels)//''' has $i values.', & + intArgs=(/size(specified_zw)/), & + messageType=MPAS_LOG_ERR) + call mpas_log_write(''''//trim(config_specified_zeta_levels)//''' must contain nVertLevels+1 ($i) values.', & + intArgs=(/nVertLevels+1/), & + messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Fourth order smoother for terrain + ! + allocate(hs (nCells+1)) + allocate(hs1(nCells+1)) + + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'edgesOnCell', edgesOnCell) + call mpas_pool_get_field(mesh, 'ter', ter_field) + call mpas_pool_get_config(configs, 'config_nsmterrain', config_nsmterrain) + nsmterrain = config_nsmterrain + + do i = 1, nsmterrain + + do iCell = 1, nCells + hs(iCell) = 0.0 + if (ter(iCell) /= 0.0) then + do j = 1, nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the terrain value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the terrain in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + ter(nCells+1) = ter(iCell) + end if + + hs(iCell) = hs(iCell) + dvEdge(edgesOnCell(j,iCell)) & + / dcEdge(edgesOnCell(j,iCell)) & + * (ter(cellsOnCell(j,iCell))-ter(iCell)) + end do + end if + + hs(iCell) = ter(iCell) + 0.216 * hs(iCell) + end do + + do iCell = 1, nCells + ter(iCell) = 0.0 + if (hs(iCell) /= 0.0) then + do j = 1, nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the terrain value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the terrain in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + hs(nCells+1) = hs(iCell) + end if + + ter(iCell) = ter(iCell) + dvEdge(edgesOnCell(j,iCell)) & + / dcEdge(edgesOnCell(j,iCell)) & + * (hs(cellsOnCell(j,iCell))-hs(iCell)) + end do + end if + + ter(iCell) = hs(iCell) - 0.216 * ter(iCell) + end do + + call mpas_dmpar_exch_halo_field(ter_field) + end do + + call mpas_pool_get_array(mesh, 'hx', hx) + do iCell = 1, nCells + hx(:,iCell) = ter(iCell) + end do + + + ! + ! Metrics for hybrid coordinate and vertical stretching + ! + + zw(:) = specified_zw(:) + zt = zw(nVertLevels+1) + + deallocate(specified_zw) + + +! ah(k) governs the transition between terrain-following +! and pure height coordinates +! ah(k) = 1 is a smoothed terrain-following coordinate +! ah(k) = 1.-zw(k)/zt is the basic terrain-following coordinate +! ah(k) = 0 is a height coordinate + + hybrid = .true. + + kz = nVertLevels+1 + if (hybrid) then + + zh = 30000.0 +! zh = 0.5*zt + + do k = 1, nVertLevels+1 + if (zw(k) < zh) then + ah(k) = cos(0.5*pii*zw(k)/zh)**6 + +!!! ah(k) = ah(k)*(1.0 - zw(k)/zt) + + else + ah(k) = 0.0 + kz = min(kz,k) + end if + end do + + else + + do k = 1, nVertLevels+1 + ah(k) = 1.0 - zw(k)/zt + end do + + end if + + call mpas_log_write('') + call mpas_log_write('k zw(k) ah(k)') + call mpas_log_write('-----------------------------------------') + do k = 1, nVertLevels+1 + call mpas_log_write('$i $r $r', intArgs=(/k/), realArgs=(/zw(k), ah(k)/)) + end do + + call mpas_pool_get_array(mesh, 'rdzw', rdzw) + call mpas_pool_get_array(mesh, 'dzu', dzu) + call mpas_pool_get_array(mesh, 'rdzu', rdzu) + call mpas_pool_get_array(mesh, 'fzm', fzm) + call mpas_pool_get_array(mesh, 'fzp', fzp) + + do k = 1, nVertLevels + dzw (k) = zw(k+1) - zw(k) + rdzw(k) = 1.0 / dzw(k) + zu(k ) = 0.5*(zw(k) + zw(k+1)) + end do + do k = 2, nVertLevels + dzu(k) = 0.5*(dzw(k) + dzw(k-1)) + rdzu(k) = 1.0 / dzu(k) + fzm(k) = 0.5*dzw(k )/dzu(k) + fzp(k) = 0.5*dzw(k-1)/dzu(k) + rdzwp(k) = dzw(k-1)/(dzw(k )*(dzw(k)+dzw(k-1))) + rdzwm(k) = dzw(k )/(dzw(k-1)*(dzw(k)+dzw(k-1))) + end do + + + call mpas_pool_get_array(mesh, 'cf1', cf1) + call mpas_pool_get_array(mesh, 'cf2', cf2) + call mpas_pool_get_array(mesh, 'cf3', cf3) + + cof1 = (2.0*dzu(2)+dzu(3))/(dzu(2)+dzu(3))*dzw(1)/dzu(2) + cof2 = dzu(2) /(dzu(2)+dzu(3))*dzw(1)/dzu(3) + cf1 = fzp(2) + cof1 + cf2 = fzm(2) - cof1 - cof2 + cf3 = cof2 + +! d1 = .5*dzw(1) +! d2 = dzw(1)+.5*dzw(2) +! d3 = dzw(1)+dzw(2)+.5*dzw(3) +! cf1 = d2*d3*(d3-d2)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) +! cf2 = d1*d3*(d1-d3)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) +! cf3 = d1*d2*(d2-d1)/(d2*d3*(d3-d2)+d1*d3*(d1-d3)+d1*d2*(d2-d1)) + + + ! + ! Smoothing algorithm for coordinate surfaces + ! + call mpas_pool_get_config(configs, 'config_smooth_surfaces', config_smooth_surfaces) + call mpas_pool_get_config(configs, 'config_nsm', config_nsm) + call mpas_pool_get_config(configs, 'config_dzmin', config_dzmin) + + if (config_smooth_surfaces) then + + dzmin = config_dzmin + + allocate(sm0(nCells+1)) + + do iCell = 1, nCells + dcsum = 0.0 + do j = 1, nEdgesOnCell(iCell) + dcsum = dcsum + dcEdge(edgesOnCell(j,iCell)) + end do + dcsum = dcsum / real(nEdgesOnCell(iCell)) + sm0(iCell) = max(0.01_RKIND, 0.125 * min(1.0_RKIND, 3000.0_RKIND/dcsum)) + end do + + + call mpas_log_write('') + call mpas_log_write('k nsm sm dzminf / dzw') + call mpas_log_write('-----------------------------------------') + + do k = 2, kz-1 + hx(k,:) = hx(k-1,:) + dzminf = zw(k) - zw(k-1) + + do i = 1, config_nsm + k + do iCell = 1, nCells + + sm = sm0(iCell) * min((3.0*zw(k)/zt)**2.0, 1.0_RKIND) + + hs1(iCell) = 0.0 + do j = 1, nEdgesOnCell(iCell) + + ! For smoothing at cells along the boundary of the mesh, set the hx value + ! for non-existent neighbors, which map to the "garbage cell", to the same as + ! the hx in the cell being smoothed + if (cellsOnCell(j,iCell) == nCells+1) then + hx(k,nCells+1) = hx(k,iCell) + end if + + hs1(iCell) = hs1(iCell) + dvEdge(edgesOnCell(j,iCell)) & + / dcEdge(edgesOnCell(j,iCell)) & + * (hx(k,cellsOnCell(j,iCell))-hx(k,iCell)) + end do + hs(iCell) = hx(k,iCell) + sm*hs1(iCell) + + end do + + tempField => tempFieldTarget + tempField % block => block + tempField % dimSizes(1) = nCells + tempField % sendList => block % parinfo % cellsToSend + tempField % recvList => block % parinfo % cellsToRecv + tempField % copyList => block % parinfo % cellsToCopy + tempField % array => hs + tempField % isActive = .true. + tempField % prev => null() + tempField % next => null() + + call mpas_dmpar_exch_halo_field(tempField) + + do iCell = 1, nCells + dzmina = (zw(k) + ah(k)*hs(iCell)) - (zw(k-1) + ah(k-1)*hx(k-1,iCell)) + if (dzmina > dzmin*(zw(k)-zw(k-1))) then + hx(k,iCell) = hs(iCell) + if (dzmina < dzminf) then + dzminf = dzmina + end if + end if + end do + + end do + call mpas_dmpar_min_real(dminfo, dzminf, dzminf_global) + call mpas_log_write('$i $i $r $r', intArgs=(/k,i/), realArgs=(/sm,dzminf_global/(zw(k)-zw(k-1))/)) + end do + + deallocate(sm0) + + do k = kz, nVertLevels+1 + hx(k,:) = 0.0 + end do + + else + + do k = 2, nVertLevels+1 + dzmina = minval(zw(k)+ah(k)*hx(k,:)-zw(k-1)-ah(k-1)*hx(k-1,:)) + call mpas_log_write('$i $r', intArgs=(/k/), realArgs=(/dzmina/(zw(k)-zw(k-1))/)) + end do + + end if + + deallocate(hs ) + deallocate(hs1) + + + ! + ! Height of coordinate levels (calculation of zgrid) + ! + + call mpas_pool_get_array(mesh, 'cellsOnEdge', cellsOnEdge) + call mpas_pool_get_array(mesh, 'zgrid', zgrid) + call mpas_pool_get_array(mesh, 'zxu', zxu) + call mpas_pool_get_array(mesh, 'zz', zz) + + do iCell = 1, nCells + do k = 1, nVertLevels+1 + zgrid(k,iCell) = zw(k) + ah(k)*hx(k,iCell) + end do + do k = 1, nVertLevels + zz (k,iCell) = (zw(k+1)-zw(k))/(zgrid(k+1,iCell)-zgrid(k,iCell)) + end do + end do + + do i = 1, nEdges + cell1 = cellsOnEdge(1,i) + cell2 = cellsOnEdge(2,i) + do k = 1, nVertLevels + zxu (k,i) = 0.5 * (zgrid(k,cell2)-zgrid(k,cell1) + zgrid(k+1,cell2)-zgrid(k+1,cell1)) / dcEdge(i) + end do + end do + + + ! + ! For z-metric term in omega equation + ! + + call mpas_pool_get_config(configs, 'config_theta_adv_order', config_theta_adv_order) + + call mpas_pool_get_array(mesh, 'deriv_two', deriv_two) + call mpas_pool_get_array(mesh, 'zb', zb) + call mpas_pool_get_array(mesh, 'zb3', zb3) + + do iEdge = 1, nEdges + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + ! Avoid referencing the garbage cell for exterior edges + if (cell1 == nCells+1) then + cell1 = cell2 + end if + if (cell2 == nCells+1) then + cell2 = cell1 + end if + + if (cell1 <= nCellsSolve .or. cell2 <= nCellsSolve) then + + do k = 1, nVertLevels + + if (config_theta_adv_order == 2) then + + z_edge = 0.5 * (zgrid(k,cell1)+zgrid(k,cell2)) + + else !theta_adv_order == 3 or 4 + + d2fdx2_cell1 = deriv_two(1,1,iEdge) * zgrid(k,cell1) + d2fdx2_cell2 = deriv_two(1,2,iEdge) * zgrid(k,cell2) + do i = 1, nEdgesOnCell(cell1) + if (cellsOnCell(i,cell1) > 0) then + d2fdx2_cell1 = d2fdx2_cell1 + deriv_two(i+1,1,iEdge) * zgrid(k,cellsOnCell(i,cell1)) + end if + end do + do i = 1, nEdgesOnCell(cell2) + if (cellsOnCell(i,cell2) > 0) then + d2fdx2_cell2 = d2fdx2_cell2 + deriv_two(i+1,2,iEdge) * zgrid(k,cellsOnCell(i,cell2)) + end if + end do + + z_edge = 0.5*(zgrid(k,cell1) + zgrid(k,cell2)) & + - (dcEdge(iEdge) **2) * (d2fdx2_cell1 + d2fdx2_cell2) / 12.0 + + if (config_theta_adv_order == 3) then + z_edge3 = - (dcEdge(iEdge) **2) * (d2fdx2_cell1 - d2fdx2_cell2) / 12.0 + else + z_edge3 = 0.0 + end if + + end if + + zb(k,1,iEdge) = (z_edge-zgrid(k,cell1))*dvEdge(iEdge)/areaCell(cell1) + zb(k,2,iEdge) = (z_edge-zgrid(k,cell2))*dvEdge(iEdge)/areaCell(cell2) + + zb3(k,1,iEdge) = z_edge3*dvEdge(iEdge)/areaCell(cell1) + zb3(k,2,iEdge) = z_edge3*dvEdge(iEdge)/areaCell(cell2) + + end do + + end if + + end do + + end subroutine init_atm_case_cam_mpas + + + integer function nearest_edge(target_lat, target_lon, & + start_edge, & + nCells, nEdges, maxEdges, nEdgesOnCell, edgesOnCell, cellsOnEdge, latCell, lonCell, latEdge, lonEdge) + + implicit none + + real (kind=RKIND), intent(in) :: target_lat, target_lon + integer, intent(in) :: start_edge + integer, intent(in) :: nCells, nEdges, maxEdges + integer, dimension(nCells), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells), intent(in) :: edgesOnCell + integer, dimension(2,nEdges), intent(in) :: cellsOnEdge + real (kind=RKIND), dimension(nCells), intent(in) :: latCell, lonCell + real (kind=RKIND), dimension(nEdges), intent(in) :: latEdge, lonEdge + + integer :: i, cell1, cell2, iCell + integer :: iEdge + integer :: current_edge + real (kind=RKIND) :: cell1_dist, cell2_dist + real (kind=RKIND) :: current_distance, d + real (kind=RKIND) :: nearest_distance nearest_edge = start_edge current_edge = -1 @@ -5002,25 +6582,13 @@ end function vertical_interp !---------------------------------------------------------------------------------------------------------- - real (kind=RKIND) function env_qv( z, temperature, pressure, rh_max ) + real (kind=RKIND) function env_qv( temperature, pressure, rh_max ) implicit none - real (kind=RKIND) :: z, temperature, pressure, ztr, es, qvs, p0, rh_max + real (kind=RKIND) :: temperature, pressure, es, qvs, p0, rh_max p0 = 100000. -! ztr = 5000. -! -! if(z .gt. ztr) then -! env_qv = 0. -! else -! if(z.lt.2000.) then -! env_qv = .5 -! else -! env_qv = .5*(1.-(z-2000.)/(ztr-2000.)) -! end if -! end if - if (pressure .lt. 50000. ) then env_qv = 0.0 else @@ -5152,7 +6720,7 @@ subroutine decouple_variables(mesh, nCells, nVertLevels, state, diag) type (mpas_pool_type), intent(inout) :: state type (mpas_pool_type), intent(inout) :: diag - integer :: iCell, iEdge, k + integer :: iCell, k integer, dimension(:,:), pointer :: cellsOnEdge real (kind=RKIND), dimension(:), pointer :: rdzw @@ -5195,4 +6763,381 @@ subroutine decouple_variables(mesh, nCells, nVertLevels, state, diag) end subroutine decouple_variables + + !----------------------------------------------------------------------- + ! routine blend_bdy_terrain + ! + !> \brief Combines first-guess terrain with static terrain along regional domain boundaries + !> \author Michael Duda + !> \date 25 April 2019 + !> \details + !> This routine combines terrain from the first-guess dataset provided in an intermediate + !> file with the terrain field produced by the init_atmosphere core's "static interpolation" + !> stage in the boundary cells of a regional mesh. Specifically, where the value of + !> the bdyMaskCell field is nBdyLayers or nBdyLayers-1, the terrain field, ter, is interpolated + !> directly from the first-guess terrain; where the value of bdy MaskCell is between nBdyLayers-2 + !> and 1, the terrain field is a combination of the first-guess terrain and the high-resolution + !> "static" terrain field. + !> + !> When dryrun=true, the nCells, latCell, lonCell, bdyMaskCell, and ter arguments are not used + !> -- only the config_met_prefix and config_start_time arguments are used. The dryrun argument + !> allows calling code to determine if blend_bdy_terrain will succeed without actually blending + !> the boundary terrain. + !> + !> For global meshes, where bdyMaskCell == 0 everywhere, this routine will have no impact + !> on the model terrain field. + ! + !----------------------------------------------------------------------- + subroutine blend_bdy_terrain(config_met_prefix, config_start_time, nCells, latCell, lonCell, bdyMaskCell, ter, dryrun, ierr) + + use init_atm_read_met, only : read_met_init, read_met_close, read_next_met_field, met_data + use init_atm_llxy, only : map_init, map_set, proj_info, latlon_to_ij, PROJ_LATLON, PROJ_GAUSS, DEG_PER_RAD + use init_atm_hinterp, only : interp_sequence, FOUR_POINT + + implicit none + + character(len=*), intent(in) :: config_met_prefix + character(len=*), intent(in) :: config_start_time + integer, intent(in) :: nCells + real (kind=RKIND), dimension(:), intent(in) :: latCell ! These four variables (latCell, lonCell, bdyMaskCell, and ter) + real (kind=RKIND), dimension(:), intent(in) :: lonCell ! may actually have more than nCells elements, for example, + integer, dimension(:), intent(in) :: bdyMaskCell ! if the arrays include a "garbage cell". + real (kind=RKIND), dimension(:), intent(inout) :: ter ! + logical, intent(in) :: dryrun + integer, intent(out) :: ierr + + integer, parameter :: nBdyLayers = 7 ! The number of relaxation layers plus the number of specified layers + integer, parameter :: nSpecLayers = 2 ! The number of specified layers + + integer :: i + integer :: istatus + integer, dimension(2) :: interp_list + real (kind=RKIND) :: weight + real (kind=RKIND) :: lat, lon + real (kind=RKIND) :: x, y + real (kind=RKIND), allocatable, dimension(:,:) :: rslab + type (met_data) :: field + type (proj_info) :: proj + + + ierr = 0 + + if (.not. dryrun) then + call mpas_log_write('Blending first-guess terrain field along domain boundary') + end if + + call read_met_init(trim(config_met_prefix), .false., config_start_time(1:13), istatus) + + if (istatus /= 0) then + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('Error opening file with terrain field, '//trim(config_met_prefix)//':'//config_start_time(1:13), & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + + ! + ! Loop over fields in the intermediate file looking for the SOILHGT field + ! + call read_next_met_field(field, istatus) + do while (istatus == 0) + if (trim(field % field) == 'SOILHGT') then + + if (.not. dryrun) then + interp_list(1) = FOUR_POINT + interp_list(2) = 0 + + ! + ! Set up map projection - currently, only the regular lat-lon projection is handled + ! + call map_init(proj) + + if (field % iproj == PROJ_LATLON) then + call map_set(PROJ_LATLON, proj, & + latinc = real(field % deltalat,RKIND), & + loninc = real(field % deltalon,RKIND), & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) + else if (field % iproj == PROJ_GAUSS) then + call map_set(PROJ_GAUSS, proj, & + nlat = nint(field % deltalat), & + loninc = 360.0_RKIND / real(field % nx,RKIND), & + lat1 = real(field % startlat,RKIND), & + lon1 = real(field % startlon,RKIND)) + end if + + ! + ! Copy the first-guess terrain field into an array that includes some periodic points + ! + allocate(rslab(-2:field % nx+3, field % ny)) + rslab(1:field % nx, 1:field % ny) = field % slab(1:field % nx, 1:field % ny) + rslab(0, 1:field % ny) = field % slab(field % nx, 1:field % ny) + rslab(-1, 1:field % ny) = field % slab(field % nx-1, 1:field % ny) + rslab(-2, 1:field % ny) = field % slab(field % nx-2, 1:field % ny) + rslab(field % nx+1, 1:field % ny) = field % slab(1, 1:field % ny) + rslab(field % nx+2, 1:field % ny) = field % slab(2, 1:field % ny) + rslab(field % nx+3, 1:field % ny) = field % slab(3, 1:field % ny) + + ! + ! For each cell in the MPAS mesh, perform terrain blending if the cell is a boundary cell + ! + do i=1,nCells + if (bdyMaskCell(i) > 0) then + lat = latCell(i)*DEG_PER_RAD + lon = lonCell(i)*DEG_PER_RAD + call latlon_to_ij(proj, lat, lon, x, y) + if (x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= real(field%nx)+0.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 0.5) then + y = 1.0 + else if (y >= real(field%ny)+0.5) then + y = real(field%ny) + end if + + ! + ! Is this a specified cell? + ! + if (bdyMaskCell(i) > (nBdyLayers - nSpecLayers)) then + ter(i) = interp_sequence(x, y, 1, rslab, -2, field%nx + 3, 1, field%ny, & + 1, 1, -1.0E30_RKIND, interp_list, 1) + + ! + ! Or a relaxation cell? + ! + else + weight = real(bdyMaskCell(i),kind=RKIND) / real(nBdyLayers - nSpecLayers,kind=RKIND) + ter(i) = weight * interp_sequence(x, y, 1, rslab, -2, field%nx + 3, 1, field%ny, & + 1, 1, -1.0E30_RKIND, interp_list, 1) & + + (1.0_RKIND - weight) * ter(i) + + end if + end if + end do + + deallocate(rslab) + end if + + ! + ! At this point, we have found and processed the first-guess terrain field, so we can return + ! + deallocate(field % slab) + call read_met_close() + return + + end if + + deallocate(field % slab) + call read_next_met_field(field, istatus) + end do + + call read_met_close() + + ! + ! If we have reached this point, no first-guess terrain field was found... + ! + ierr = 1 + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + call mpas_log_write('SOILHGT field not found in intermediate file ' & + //trim(config_met_prefix)//':'//config_start_time(1:13) , & + messageType=MPAS_LOG_ERR) + call mpas_log_write('********************************************************************************', & + messageType=MPAS_LOG_ERR) + + end subroutine blend_bdy_terrain + + + !----------------------------------------------------------------------- + ! routine convert_relhum_wrt_ice + ! + !> \brief Converts an RH field given w.r.t. liquid water to RH w.r.t. ice below freezing + !> \author Wei Wang + !> \date 11 May 2019 + !> \details + !> This routine takes as input a temperature field (in K) and an RH field (in percent), + !> which is assumed to be with respect to liquid water everywhere. Upon return, the + !> relative humidity for temperatures below 253.15 K has been modified to be with + !> respect to ice. For temperatures in the range (253.15, 273.15] the relative humidity + !> uses a blend of the saturation mixing ratios for liquid water and ice. + !> + !> This routine uses the formula from the WPS ungrib program to re-compute RH with + !> respect to ice in an attempt to re-construct RH that is more like the ungrib input. + ! + !----------------------------------------------------------------------- + subroutine convert_relhum_wrt_ice(t, relhum) + + implicit none + + real (kind=RKIND), dimension(:,:), intent(in) :: t + real (kind=RKIND), dimension(:,:), intent(inout) :: relhum + + integer :: iCell, k + integer :: nVertLevels + integer :: nCells + real (kind=RKIND) :: eis, ews, r1 + + + nVertLevels = size(t, dim=1) + nCells = size(t, dim=2) + + call mpas_log_write('') + call mpas_log_write('Recomputing RH w.r.t. ice below freezing') + call mpas_log_write('') + + do iCell = 1, nCells + do k = 1, nVertLevels + if ( t(k,iCell) <= 273.15_RKIND ) then + + ! use formula in ungrib to reconstruct RH + eis = 0.01_RKIND * exp (9.550426_RKIND - (5723.265_RKIND / t(k,iCell)) + (3.53068_RKIND * log(t(k,iCell))) & + - (0.00728332_RKIND * t(k,iCell))) + ews = 6.112_RKIND * exp(17.67_RKIND * (t(k,iCell)-273.15_RKIND) / ((t(k,iCell)-273.15_RKIND)+243.5_RKIND)) + + ! A linear approximation to the GFS blending region ( -20 C > T < 0 C ) + if ( t(k,iCell) > 253.15_RKIND ) then + r1 = ((273.15_RKIND - t(k,iCell)) / 20.0_RKIND) + r1 = (r1 * eis) + ((1.0_RKIND-r1)*ews) + else + r1 = eis + end if + r1 = max(r1, 1.0e-12_RKIND) + ews = max(ews, 0.0_RKIND) + relhum(k,iCell) = ews / r1 * relhum(k,iCell) + relhum(k,iCell) = min(relhum(k,iCell), 100.0_RKIND) + relhum(k,iCell) = max(relhum(k,iCell), 0.0_RKIND) + end if + end do + end do + + end subroutine convert_relhum_wrt_ice + + + !----------------------------------------------------------------------- + ! routine read_text_array + ! + !> \brief Reads a real-valued array from a text file and broadcasts to all tasks + !> \author Michael Duda + !> \date 11 May 2019 + !> \details + !> This routine reads a list of real values from the specified text file on + !> the IO_NODE task and broadcasts the values to all other MPI tasks. Upon + !> successful return, the array pointer xarray will have been allocated with + !> a size equal to the number of lines in the text file, the array will be filled + !> with the values from the file, and a value of 0 will be returned. + !> + !> This routine will print an error message and return a non-zero value if + !> any of the following conditions occur: + !> + !> 1) The text file does not exist + !> 2) The text file cannot be opened for reading + !> 3) The text does not contain readable real values + !> + !> If the return value of this function is non-zero, the xarray pointer + !> will be unassociated. + ! + !----------------------------------------------------------------------- + function read_text_array(dminfo, filename, xarray) result(ierr) + + use mpas_io_units, only : mpas_new_unit, mpas_release_unit + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR + + implicit none + + type (dm_info), intent(in) :: dminfo + character(len=*), intent(in) :: filename + real (kind=RKIND), dimension(:), pointer :: xarray + + integer :: ierr + + integer :: i + integer :: nlines + integer :: iunit + integer :: iexists + logical :: exists + real (kind=RKIND) :: rtemp + + + ierr = 1 + nullify(xarray) + + ! + ! Check whether the file exists + ! + if (dminfo % my_proc_id == IO_NODE) then + inquire(file=filename, exist=exists) + if (exists) then + iexists = 1 + else + iexists = 0 + end if + end if + call mpas_dmpar_bcast_int(dminfo, iexists) + + if (iexists == 0) then + call mpas_log_write('Text file '''//filename//''' does not exist.', messageType=MPAS_LOG_ERR) + return + end if + + ! + ! Count the number of lines in the file + ! + if (dminfo % my_proc_id == IO_NODE) then + call mpas_new_unit(iunit) + open(unit=iunit, file=filename, form='formatted', status='old', iostat=ierr) + if (ierr /= 0) then + nlines = -1 + else + nlines = 0 + read(unit=iunit, fmt=*, iostat=ierr) rtemp + do while (ierr == 0) + nlines = nlines + 1 + read(unit=iunit, fmt=*, iostat=ierr) rtemp + end do + end if + close(unit=iunit) + call mpas_release_unit(iunit) + end if + call mpas_dmpar_bcast_int(dminfo, nlines) + + if (nlines <= 0) then + if (nlines < 0) then + call mpas_log_write('Text file '''//filename//''' could not be opened for reading.', messageType=MPAS_LOG_ERR) + else + call mpas_log_write('Text file '''//filename//''' contains no readable real values.', messageType=MPAS_LOG_ERR) + end if + ierr = 1 + return + end if + + ! + ! Allocate output array, read, and broadcast + ! + allocate(xarray(nlines)) + if (dminfo % my_proc_id == IO_NODE) then + call mpas_new_unit(iunit) + open(unit=iunit, file=filename, form='formatted', status='old', iostat=ierr) + do i=1,nlines + read(unit=iunit, fmt=*, iostat=ierr) xarray(i) + end do + close(unit=iunit) + call mpas_release_unit(iunit) + end if + + call mpas_dmpar_bcast_reals(dminfo, nlines, xarray) + ierr = 0 + + end function read_text_array + + end module init_atm_cases 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 36523bdb8a..6229e50fdc 100644 --- a/src/core_init_atmosphere/mpas_init_atm_core_interface.F +++ b/src/core_init_atmosphere/mpas_init_atm_core_interface.F @@ -56,7 +56,7 @@ subroutine init_atm_setup_core(core) core % Conventions = 'MPAS' core % source = 'MPAS' -#include "inc/core_variables.inc" +#include "core_variables.inc" end subroutine init_atm_setup_core @@ -81,7 +81,7 @@ subroutine init_atm_setup_domain(domain) type (domain_type), pointer :: domain -#include "inc/domain_variables.inc" +#include "domain_variables.inc" end subroutine init_atm_setup_domain @@ -100,21 +100,25 @@ 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 + logical :: lexist - logical, pointer :: initial_conds, sfc_update + logical, pointer :: initial_conds, sfc_update, lbcs logical, pointer :: gwd_stage_in, gwd_stage_out, vertical_stage_in, vertical_stage_out, met_stage_in, met_stage_out logical, pointer :: config_native_gwd_static, config_static_interp, config_vertical_grid, config_met_interp + logical, pointer :: first_guess_field + logical, pointer :: mp_thompson_aers_in integer, pointer :: config_init_case @@ -132,6 +136,9 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) nullify(sfc_update) call mpas_pool_get_package(packages, 'sfc_updateActive', sfc_update) + nullify(lbcs) + call mpas_pool_get_package(packages, 'lbcsActive', lbcs) + nullify(gwd_stage_in) call mpas_pool_get_package(packages, 'gwd_stage_inActive', gwd_stage_in) @@ -150,6 +157,9 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) nullify(met_stage_out) call mpas_pool_get_package(packages, 'met_stage_outActive', met_stage_out) + nullify(mp_thompson_aers_in) + call mpas_pool_get_package(packages, 'mp_thompson_aers_inActive', mp_thompson_aers_in) + if (.not. associated(initial_conds) .or. & .not. associated(sfc_update) .or. & .not. associated(gwd_stage_in) .or. & @@ -157,7 +167,8 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) .not. associated(vertical_stage_in) .or. & .not. associated(vertical_stage_out) .or. & .not. associated(met_stage_in) .or. & - .not. associated(met_stage_out)) then + .not. associated(met_stage_out) .or. & + .not. associated(mp_thompson_aers_in)) then call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('* Error while setting up packages for init_atmosphere core.', messageType=MPAS_LOG_ERR) call mpas_log_write('********************************************************************************', messageType=MPAS_LOG_ERR) @@ -173,6 +184,16 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) sfc_update = .false. end if + if (config_init_case == 9) then + lbcs = .true. + mp_thompson_aers_in = .false. + inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) + if(lexist) mp_thompson_aers_in = .true. + else + lbcs = .false. + mp_thompson_aers_in = .false. + end if + if (config_init_case == 7) then ! @@ -192,6 +213,11 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) (.not. config_static_interp) .and. & (.not. config_vertical_grid) met_stage_out = config_met_interp + + mp_thompson_aers_in = .false. + inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) + if((lexist .and. met_stage_out) .or. (lexist .and. met_stage_in)) mp_thompson_aers_in = .true. + else if (config_init_case == 8) then gwd_stage_in = .false. gwd_stage_out = .false. @@ -199,6 +225,33 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) vertical_stage_out = .false. met_stage_in = .false. met_stage_out = .false. + + ! + ! When interpolating LBC fields, we need all inputs that would be needed for the interpolation + ! of ICs, so met_stage_in = .true. + ! + else if (config_init_case == 9) then + gwd_stage_in = .false. + gwd_stage_out = .false. + vertical_stage_in = .false. + vertical_stage_out = .false. + met_stage_in = .true. + met_stage_out = .true. + + mp_thompson_aers_in = .false. + inquire(file="QNWFA_QNIFA_SIGMA_MONTHLY.dat",exist=lexist) + if((lexist .and. met_stage_out) .or. (lexist .and. met_stage_in)) mp_thompson_aers_in = .true. + + initial_conds = .false. ! Also, turn off the initial_conds package to avoid writing the IC "output" stream + + else if (config_init_case == 13) then + gwd_stage_in = .false. + gwd_stage_out = .false. + vertical_stage_in = .false. + vertical_stage_out = .true. + met_stage_in = .false. + met_stage_out = .false. + else gwd_stage_in = .false. gwd_stage_out = .false. @@ -208,6 +261,18 @@ function init_atm_setup_packages(configs, packages, iocontext) result(ierr) met_stage_out = .true. end if + ! + ! Package for 3-d first-guess atmospheric and land-surface fields is only active if + ! we are interpolating real-data ICs or LBCs + ! + nullify(first_guess_field) + call mpas_pool_get_package(packages, 'first_guess_fieldActive', first_guess_field) + + first_guess_field = .false. + if ((config_init_case == 7 .and. config_met_interp) .or. config_init_case == 9) then + first_guess_field = .true. + end if + end function init_atm_setup_packages @@ -274,15 +339,17 @@ end function init_atm_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ + function init_atm_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types, only : mpas_log_type, domain_type use mpas_log, only : mpas_log_init, mpas_log_open + use mpas_framework, only : mpas_framework_report_settings implicit none type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -291,7 +358,7 @@ function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -303,13 +370,10 @@ function init_atm_setup_log(logInfo, domain) result(iErr)!{{{ iErr = ior(iErr, local_err) call mpas_log_write('') -#ifdef SINGLE_PRECISION - call mpas_log_write('Using default single-precision reals') -#else - call mpas_log_write('Using default double-precision reals') -#endif + call mpas_log_write('MPAS Init-Atmosphere Version '//trim(domain % core % modelVersion)) call mpas_log_write('') + call mpas_framework_report_settings(domain) end function init_atm_setup_log!}}} @@ -328,15 +392,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 @@ -415,16 +480,16 @@ function init_atm_setup_block(block) result(ierr) end function init_atm_setup_block -#include "inc/setup_immutable_streams.inc" +#include "setup_immutable_streams.inc" -#include "inc/block_dimension_routines.inc" +#include "block_dimension_routines.inc" -#include "inc/define_packages.inc" +#include "define_packages.inc" -#include "inc/structs_and_variables.inc" +#include "structs_and_variables.inc" -#include "inc/namelist_call.inc" +#include "namelist_call.inc" -#include "inc/namelist_defines.inc" +#include "namelist_defines.inc" end module init_atm_core_interface diff --git a/src/core_init_atmosphere/mpas_init_atm_gwd.F b/src/core_init_atmosphere/mpas_init_atm_gwd.F index 3bc260c3c2..25ef93c8c6 100644 --- a/src/core_init_atmosphere/mpas_init_atm_gwd.F +++ b/src/core_init_atmosphere/mpas_init_atm_gwd.F @@ -7,15 +7,34 @@ ! module mpas_init_atm_gwd + use iso_c_binding, only : c_char, c_int, c_float, c_ptr, c_loc + use mpas_derived_types, only : MPAS_LOG_ERR use mpas_framework use mpas_timekeeping use mpas_log, only : mpas_log_write + use mpas_c_interfacing, only : mpas_f_to_c_string public :: compute_gwd_fields private + interface + subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & + wordsize, status) bind(C) + use iso_c_binding, only : c_char, c_int, c_float, c_ptr + character (c_char), dimension(*), intent(in) :: fname + type (c_ptr), value :: rarray + integer (c_int), intent(in), value :: nx + integer (c_int), intent(in), value :: ny + integer (c_int), intent(in), value :: nz + integer (c_int), intent(in), value :: isigned + integer (c_int), intent(in), value :: endian + integer (c_int), intent(in), value :: wordsize + integer (c_int), intent(inout) :: status + end subroutine read_geogrid + end interface + integer, parameter :: I1KIND = selected_int_kind(2) real (kind=RKIND), parameter :: Re = 6371229.0_RKIND ! Earth radius in MPAS-Atmosphere @@ -96,6 +115,7 @@ function compute_gwd_fields(domain) result(iErr) character(len=StrKIND), pointer :: config_geog_data_path character(len=StrKIND), pointer :: config_topo_data character(len=StrKIND) :: geog_sub_path + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash ! Variables for smoothing variance integer, dimension(:,:), pointer:: cellsOnCell @@ -114,6 +134,12 @@ function compute_gwd_fields(domain) result(iErr) call mpas_pool_get_config(domain % configs, 'config_topo_data', config_topo_data) call mpas_pool_get_config(domain % configs, 'config_gwd_cell_scaling', config_gwd_cell_scaling) + write(geog_data_path, '(a)') config_geog_data_path + i = len_trim(geog_data_path) + if (geog_data_path(i:i) /= '/') then + geog_data_path(i+1:i+1) = '/' + end if + select case(trim(config_topo_data)) case('GTOPO30') call mpas_log_write('--- Using GTOPO30 terrain dataset for GWDO static fields') @@ -168,13 +194,13 @@ function compute_gwd_fields(domain) result(iErr) allocate(hlanduse(nCells+1)) ! +1, since we access hlanduse(cellsOnCell(i,iCell)) later on for iCell=1,nCells - iErr = read_global_30s_topo(config_geog_data_path, geog_sub_path) + iErr = read_global_30s_topo(geog_data_path, geog_sub_path) if (iErr /= 0) then call mpas_log_write('Error reading global 30-arc-sec topography for GWD statistics', messageType=MPAS_LOG_ERR) return end if - iErr = read_global_30s_landuse(config_geog_data_path) + iErr = read_global_30s_landuse(geog_data_path) if (iErr /= 0) then call mpas_log_write('Error reading global 30-arc-sec landuse for GWD statistics', messageType=MPAS_LOG_ERR) return @@ -314,14 +340,17 @@ function read_global_30s_topo(path, sub_path) result(iErr) integer, parameter :: tile_y = 1200 ! y-dimension of each tile of global 30-arc-second topography integer, parameter :: tile_bdr = 3 ! number of layers of border/halo points surrounding each tile - integer :: istatus + integer (c_int) :: istatus integer :: ix, iy, ishift, ix_shift - integer :: isigned, endian, wordsize, nx, ny, nz - real (kind=R4KIND) :: scalefactor - real (kind=R4KIND), dimension(:,:,:), allocatable :: tile + integer (c_int) :: isigned, endian, wordsize, nx, ny, nz + real (c_float) :: scalefactor + real (c_float), dimension(:,:,:), pointer, contiguous :: tile + type (c_ptr) :: tile_ptr character(len=StrKIND) :: filename + character(kind=c_char), dimension(StrKIND+1) :: c_filename allocate(tile(tile_x+2*tile_bdr,tile_y+2*tile_bdr,1)) + tile_ptr = c_loc(tile) isigned = 1 endian = 0 @@ -345,8 +374,10 @@ function read_global_30s_topo(path, sub_path) result(iErr) do ix=1,topo_x,tile_x write(filename,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(path)//trim(sub_path), ix, '-', (ix+tile_x-1), '.', & iy, '-', (iy+tile_y-1) - call read_geogrid(filename, len_trim(filename), tile, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, istatus) + call mpas_f_to_c_string(filename, c_filename) + call read_geogrid(c_filename, tile_ptr, nx, ny, nz, isigned, endian, & + wordsize, istatus) + tile(:,:,:) = tile(:,:,:) * scalefactor if (istatus /= 0) then call mpas_log_write('Error reading topography tile '//trim(filename), messageType=MPAS_LOG_ERR) iErr = 1 @@ -389,14 +420,17 @@ function read_global_30s_landuse(path) result(iErr) integer, parameter :: tile_x = 1200 ! x-dimension of each tile of global 30-arc-second landuse integer, parameter :: tile_y = 1200 ! y-dimension of each tile of global 30-arc-second landuse - integer :: istatus + integer (c_int) :: istatus integer :: ix, iy - integer :: isigned, endian, wordsize, nx, ny, nz - real (kind=R4KIND) :: scalefactor - real (kind=R4KIND), dimension(:,:,:), allocatable :: tile + integer (c_int) :: isigned, endian, wordsize, nx, ny, nz + real (c_float) :: scalefactor + real (c_float), dimension(:,:,:), pointer, contiguous :: tile + type (c_ptr) :: tile_ptr character(len=StrKIND) :: filename + character(kind=c_char), dimension(StrKIND+1) :: c_filename allocate(tile(tile_x,tile_y,1)) + tile_ptr = c_loc(tile) isigned = 1 endian = 0 @@ -410,8 +444,10 @@ function read_global_30s_landuse(path) result(iErr) do ix=1,topo_x,tile_x write(filename,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(path)//'/landuse_30s/', ix, '-', (ix+tile_x-1), '.', & iy, '-', (iy+tile_y-1) - call read_geogrid(filename, len_trim(filename), tile, nx, ny, nz, isigned, endian, & - scalefactor, wordsize, istatus) + call mpas_f_to_c_string(filename, c_filename) + call read_geogrid(c_filename, tile_ptr, nx, ny, nz, isigned, endian, & + wordsize, istatus) + tile(:,:,:) = tile(:,:,:) * scalefactor if (istatus /= 0) then call mpas_log_write('Error reading landuse tile '//trim(filename)) iErr = 1 diff --git a/src/core_init_atmosphere/mpas_init_atm_read_met.F b/src/core_init_atmosphere/mpas_init_atm_read_met.F index 510fa4574d..45cd3121b5 100644 --- a/src/core_init_atmosphere/mpas_init_atm_read_met.F +++ b/src/core_init_atmosphere/mpas_init_atm_read_met.F @@ -51,6 +51,7 @@ subroutine read_met_init(fg_source, source_is_constant, datestr, istatus) use mpas_derived_types, only : MPAS_LOG_ERR use mpas_log, only : mpas_log_write + use mpas_io_units, only : mpas_new_unit implicit none @@ -75,11 +76,8 @@ subroutine read_met_init(fg_source, source_is_constant, datestr, istatus) end if ! 2) OPEN FILE - do input_unit=10,100 - inquire(unit=input_unit, opened=is_used) - if (.not. is_used) exit - end do - if (input_unit > 100) call mpas_log_write('In read_met_init(), couldn''t find an available Fortran unit.', messageType=MPAS_LOG_ERR) + call mpas_new_unit(input_unit, unformatted = .true.) + if (input_unit < 0) call mpas_log_write('In read_met_init(), couldn''t find an available Fortran unit.', messageType=MPAS_LOG_ERR) open(unit=input_unit, file=trim(filename), status='old', form='unformatted', iostat=io_status) if (io_status > 0) istatus = 1 @@ -418,9 +416,12 @@ end subroutine read_next_met_field !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine read_met_close() + use mpas_io_units, only : mpas_release_unit + implicit none close(unit=input_unit) + call mpas_release_unit(input_unit) filename = 'UNINITIALIZED_FILENAME' end subroutine read_met_close diff --git a/src/core_init_atmosphere/mpas_init_atm_static.F b/src/core_init_atmosphere/mpas_init_atm_static.F index 322edc5fee..09fe4c57a1 100644 --- a/src/core_init_atmosphere/mpas_init_atm_static.F +++ b/src/core_init_atmosphere/mpas_init_atm_static.F @@ -15,9 +15,16 @@ module mpas_init_atm_static use mpas_log, only : mpas_log_write use init_atm_hinterp use init_atm_llxy + use mpas_c_interfacing, only : mpas_f_to_c_string + use mpas_geometry_utils, only : mpas_in_cell use mpas_atmphys_utilities + use mpas_kd_tree, only : mpas_kd_type, mpas_kd_construct, mpas_kd_free, mpas_kd_search + use mpas_geotile_manager, only : mpas_geotile_mgr_type, mpas_geotile_type, mpas_latlon_to_xyz + + use iso_c_binding, only : c_char, c_int, c_float, c_loc, c_ptr + implicit none private public:: init_atm_static, & @@ -25,6 +32,78 @@ module mpas_init_atm_static nearest_cell, & sphere_distance +!constants + integer, parameter :: nBdyLayers = 7 ! The number of relaxation layers plus the number of specified layers + ! This value is used in determining whether extra checks are needed + ! in the remapping of terrain, land use, and soil category pixels + + interface + subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & + wordsize, status) bind(C) + use iso_c_binding, only : c_char, c_int, c_float, c_ptr + character (c_char), dimension(*), intent(in) :: fname + type (c_ptr), value :: rarray + integer (c_int), intent(in), value :: nx + integer (c_int), intent(in), value :: ny + integer (c_int), intent(in), value :: nz + integer (c_int), intent(in), value :: isigned + integer (c_int), intent(in), value :: endian + integer (c_int), intent(in), value :: wordsize + integer (c_int), intent(inout) :: status + end subroutine read_geogrid + end interface + + ! Abstract interface for determining if the cell, iCell, needs to be added to the stack + ! for processing. If an interface returns .true., it will indicate to the calling code + ! that the cell has not received any mappings and needs to be processed. Returning .false. + ! will indicate that the cell has received mappings and does not need to be processed. + abstract interface + function interp_criteria_function(iCell) + integer, intent(in) :: iCell + logical :: interp_criteria_function + end function interp_criteria_function + end interface + + ! Abstract interface to accumulate pixel values with the cell they map to. Depending on + ! the dataset, values may need to be accumulated in different ways (continuous vs. + ! categorical) or specific values of a dataset may need to be ignored (for instance, + ! ignoring pixels over water), this routine allows interpolations to differ according + ! to each dataset's needs + abstract interface + subroutine interp_accumulation_function(iCell, pixel) + use mpas_derived_types, only : I8KIND + integer, intent(in) :: iCell + ! Note: Datasets that are have one grid point in the z direction (tile_z = 1) + ! will need to access pixel values as pixel(1) + integer (kind=I8KIND), dimension(:), intent(in) :: pixel + end subroutine interp_accumulation_function + end interface + + ! + ! Module level variables needed for the unified static interpolation function. This is not + ! ideal, a better solution would be to have these variables reside in each interpolation + ! function (e.g. interp_terrain) and then have the criteria and accumulation functions + ! be internal/nested subroutines; however, passing a nested subroutine (internal + ! subroutine) as an actual argument is not allowed in the 2003 standard (Section + ! 12.1.2.2 of the Fortran standard) and currently, only PGI does not support this, so + ! use module level variables for now... + ! + integer (kind=I8KIND), dimension(:), pointer :: ter_integer + integer (kind=I8KIND), dimension(:,:), pointer :: soilcomp_int + real (kind=RKIND) :: soilcomp_msgval = 255.0_RKIND ! Modified later based on index file for soilcomp + integer, dimension(:), pointer :: lu_index + integer, dimension(:), pointer :: soilcat_top + integer, dimension(:), pointer :: nhs + integer, dimension(:,:), allocatable:: ncat + ! Landmask is used by the accumulation function for maxsnoalb and soilcomp, + ! so it needs to be a global variable + integer, dimension(:), pointer :: landmask + + integer, pointer :: category_min + integer, pointer :: category_max + + real(kind=RKIND) :: max_kdtree_distance2 + contains !================================================================================================== @@ -40,40 +119,46 @@ subroutine init_atm_static(mesh, dims, configs) type(proj_info):: proj character(len=StrKIND) :: fname + character(kind=c_char), dimension(StrKIND+1) :: c_fname character(len=StrKIND), pointer :: config_geog_data_path character(len=StrKIND), pointer :: config_landuse_data character(len=StrKIND), pointer :: config_topo_data + character(len=StrKIND), pointer :: config_vegfrac_data + character(len=StrKIND), pointer :: config_albedo_data + character(len=StrKIND), pointer :: config_maxsnowalbedo_data character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash character(len=StrKIND+1) :: geog_sub_path ! subdirectory names in config_geog_data_path, with trailing slash - integer:: isice_lu,iswater_lu,ismax_lu - - integer:: nx,ny,nz - integer:: endian,isigned,istatus,wordsize + integer(c_int):: nx,ny,nz + integer(c_int):: endian,isigned,istatus,wordsize integer:: i,j,k - integer:: iCell,iEdge,iVtx,iPoint,iTileStart,iTileEnd,jTileStart,jTileEnd + integer :: ii, jj + integer:: iCell,iEdge,iVtx integer,dimension(5) :: interp_list integer,dimension(:),allocatable :: nhs - integer,dimension(:,:),allocatable:: ncat - real(kind=4):: scalefactor - real(kind=4),dimension(:,:,:),allocatable:: rarray + real(kind=RKIND), pointer :: scalefactor_ptr + real(kind=RKIND) :: scalefactor + real(kind=c_float),dimension(:,:,:),pointer,contiguous :: rarray + type(c_ptr) :: rarray_ptr - real(kind=RKIND):: start_lat - real(kind=RKIND):: start_lon + integer, pointer :: supersample_fac + integer, pointer :: supersample_fac_30s real(kind=RKIND):: lat,lon,x,y real(kind=RKIND):: lat_pt,lon_pt - real(kind=RKIND),dimension(:,:),allocatable :: soiltemp_1deg real(kind=RKIND),dimension(:,:),allocatable :: maxsnowalb real(kind=RKIND),dimension(:,:,:),allocatable:: vegfra - integer, pointer :: nCells, nEdges, nVertices, maxEdges + integer, pointer :: isice_lu, iswater_lu + integer :: iswater_soil + integer, pointer :: nCells, nCellsSolve, nEdges, nVertices, maxEdges logical, pointer :: on_a_sphere real (kind=RKIND), pointer :: sphere_radius integer, dimension(:), pointer :: nEdgesOnCell integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:,:), pointer :: verticesOnCell real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex real (kind=RKIND), dimension(:), pointer :: xEdge, yEdge, zEdge @@ -84,18 +169,42 @@ subroutine init_atm_static(mesh, dims, configs) real (kind=RKIND), dimension(:), pointer :: latVertex, lonVertex real (kind=RKIND), dimension(:), pointer :: latEdge, lonEdge real (kind=RKIND), dimension(:), pointer :: fEdge, fVertex + real (kind=RKIND), pointer :: nominalMinDc - real (kind=RKIND), dimension(:), pointer :: ter - real (kind=RKIND), dimension(:), pointer :: soiltemp + integer (kind=I8KIND), dimension(:,:), pointer :: greenfrac_int real (kind=RKIND), dimension(:), pointer :: snoalb + integer (kind=I8KIND), dimension(:), pointer :: snoalb_integer real (kind=RKIND), dimension(:), pointer :: shdmin, shdmax real (kind=RKIND), dimension(:,:), pointer :: greenfrac real (kind=RKIND), dimension(:,:), pointer :: albedo12m + integer (kind=I8KIND), dimension(:,:), pointer :: albedo12m_int + real (kind=RKIND) :: fillval + real (kind=RKIND), pointer :: missing_value integer, dimension(:), pointer :: lu_index integer, dimension(:), pointer :: soilcat_top integer, dimension(:), pointer :: landmask + integer, dimension(:), pointer :: bdyMaskCell character(len=StrKIND), pointer :: mminlu + real (kind=RKIND) :: xPixel, yPixel, zPixel + + type (mpas_kd_type), dimension(:), pointer :: kd_points + type (mpas_kd_type), pointer :: tree + type (mpas_kd_type), pointer :: res + + type (mpas_geotile_mgr_type) :: mgr + type (mpas_geotile_type), pointer :: tile + + integer (kind=I8KIND) :: i8val + integer, pointer :: tile_bdr + integer, pointer :: tile_nx, tile_ny, tile_nz + integer, pointer :: tile_z_start, tile_z_end + + logical :: all_pixels_mapped_to_halo_cells + integer :: ierr + + real(kind=RKIND) :: max_diameter + !-------------------------------------------------------------------------------------------------- @@ -105,6 +214,11 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_config(configs, 'config_geog_data_path', config_geog_data_path) call mpas_pool_get_config(configs, 'config_landuse_data', config_landuse_data) call mpas_pool_get_config(configs, 'config_topo_data', config_topo_data) + call mpas_pool_get_config(configs, 'config_vegfrac_data', config_vegfrac_data) + 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) @@ -139,16 +253,18 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_array(mesh, 'lonVertex', lonVertex) call mpas_pool_get_array(mesh, 'fEdge', fEdge) call mpas_pool_get_array(mesh, 'fVertex', fVertex) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) call mpas_pool_get_array(mesh, 'cellsOnCell', cellsOnCell) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) - call mpas_pool_get_array(mesh, 'ter', ter) call mpas_pool_get_array(mesh, 'lu_index', lu_index) call mpas_pool_get_array(mesh, 'mminlu', mminlu) + call mpas_pool_get_array(mesh, 'isice_lu', isice_lu) + call mpas_pool_get_array(mesh, 'iswater_lu', iswater_lu) call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) call mpas_pool_get_array(mesh, 'landmask', landmask) - call mpas_pool_get_array(mesh, 'soiltemp', soiltemp) call mpas_pool_get_array(mesh, 'snoalb', snoalb) call mpas_pool_get_array(mesh, 'greenfrac', greenfrac) call mpas_pool_get_array(mesh, 'albedo12m', albedo12m) @@ -159,10 +275,13 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_dimension(dims, 'nCellsSolve', nCellsSolve) call mpas_pool_get_dimension(dims, 'nEdges', nEdges) call mpas_pool_get_dimension(dims, 'nVertices', nVertices) call mpas_pool_get_dimension(dims, 'maxEdges', maxEdges) + call mpas_pool_get_array(mesh, 'nominalMinDc', nominalMinDc) + xCell = xCell * sphere_radius yCell = yCell * sphere_radius zCell = zCell * sphere_radius @@ -178,6 +297,32 @@ subroutine init_atm_static(mesh, dims, configs) areaTriangle = areaTriangle * sphere_radius**2.0 kiteAreasOnVertex = kiteAreasOnVertex * sphere_radius**2.0 + nominalMinDc = nominalMinDc * sphere_radius + +! +! Set max squared distance for k-d tree search to twice the squared cell diameter +! The factor of two is simply a safety factor to account for possible inaccuracies +! in the distance function used in the k-d tree +! + max_diameter = max_cell_diameter(nCells, nEdgesOnCell, verticesOnCell, latCell, lonCell, & + latVertex, lonVertex, sphere_radius) + max_kdtree_distance2 = 2.0_RKIND * max_diameter**2 + +! +! Initialize the KD-Tree +! + allocate(kd_points(nCells)) + do i = 1, nCells + allocate(kd_points(i) % point(3)) + kd_points(i) % point = (/xCell(i), yCell(i), zCell(i)/) + kd_points(i) % id = i ! Cell ID + enddo + tree => null() + tree => mpas_kd_construct(kd_points, 3) + if (.not. associated(tree)) then + call mpas_log_write('Error creating the KD-Tree for static interpolation', messageType=MPAS_LOG_CRIT) + endif + ! ! Initialize Coriolis parameter field on edges and vertices @@ -202,14 +347,8 @@ subroutine init_atm_static(mesh, dims, configs) ! surface_input_select0: select case(trim(config_landuse_data)) case('USGS') - isice_lu = 24 - iswater_lu = 16 - ismax_lu = 24 write(mminlu,'(a)') 'USGS' case('MODIFIED_IGBP_MODIS_NOAH') - isice_lu = 15 - iswater_lu = 17 - ismax_lu = 20 write(mminlu,'(a)') 'MODIFIED_IGBP_MODIS_NOAH' case default call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) @@ -220,34 +359,16 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select surface_input_select0 - ! ! Interpolate HGT ! -!nx = 126 -!ny = 126 - nx = 1206 - ny = 1206 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 2 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(nhs(nCells)) - nhs(:) = 0 - ter(:) = 0.0 - - start_lat = -89.99583 select case(trim(config_topo_data)) case('GTOPO30') call mpas_log_write('Using GTOPO30 terrain dataset') geog_sub_path = 'topo_30s/' - start_lon = -179.99583 case('GMTED2010') call mpas_log_write('Using GMTED2010 terrain dataset') geog_sub_path = 'topo_gmted2010_30s/' - start_lon = 0.004166667 case('default') call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Invalid topography dataset '''//trim(config_topo_data) & @@ -257,43 +378,9 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select - do jTileStart = 1,20401,ny-6 - jTileEnd = jTileStart + ny - 1 - 6 - - do iTileStart=1,42001,nx-6 - iTileEnd = iTileStart + nx - 1 - 6 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)//trim(geog_sub_path), & - iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=4,ny-3 - do i=4,nx-3 - lat_pt = start_lat + (jTileStart + j - 5) * 0.0083333333 - lon_pt = start_lon + (iTileStart + i - 5) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - ter(iPoint) = ter(iPoint) + rarray(i,j,1) - nhs(iPoint) = nhs(iPoint) + 1 - end do - end do - - end do - end do - - do iCell = 1,nCells - ter(iCell) = ter(iCell) / real(nhs(iCell)) - end do - deallocate(rarray) - deallocate(nhs) + call mpas_log_write('--- start interpolate TER') + 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') @@ -302,8 +389,10 @@ subroutine init_atm_static(mesh, dims, configs) ! surface_input_select1: select case(trim(config_landuse_data)) case('USGS') + call mpas_log_write('Using 24-class USGS 30-arc-second land cover dataset') geog_sub_path = 'landuse_30s/' case('MODIFIED_IGBP_MODIS_NOAH') + call mpas_log_write('Using 20-class MODIS 30-arc-second land cover dataset') geog_sub_path = 'modis_landuse_20class_30s/' case default call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) @@ -313,126 +402,22 @@ subroutine init_atm_static(mesh, dims, configs) call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) end select surface_input_select1 - nx = 1200 - ny = 1200 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(ncat(ismax_lu,nCells)) - ncat(:,:) = 0 - lu_index(:) = 0.0 - - do jTileStart = 1,20401,ny - jTileEnd = jTileStart + ny - 1 - - do iTileStart = 1,42001,nx - iTileEnd = iTileStart + nx - 1 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - trim(geog_sub_path),iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=1,ny - do i=1,nx -! -! The MODIS dataset appears to have zeros at the South Pole, possibly other places, too -! -if (rarray(i,j,1) == 0) cycle - - lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333 - lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 - end do - end do - end do - end do - - do iCell = 1,nCells - lu_index(iCell) = 1 - do i = 2,ismax_lu - if(ncat(i,iCell) > ncat(lu_index(iCell),iCell)) then - lu_index(iCell) = i - end if - end do - end do - deallocate(rarray) - deallocate(ncat) + 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, & + supersample_fac=supersample_fac_30s) call mpas_log_write('--- end interpolate LU_INDEX') - ! ! Interpolate SOILCAT_TOP ! - nx = 1200 - ny = 1200 - nz = 1 - isigned = 1 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(ncat(16,nCells)) - ncat(:,:) = 0 - soilcat_top(:) = 0.0 - - do jTileStart = 1,20401,ny - jTileEnd = jTileStart + ny - 1 - - do iTileStart = 1,42001,nx - iTileEnd = iTileStart + nx - 1 - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'soiltype_top_30s/',iTileStart,'-',iTileEnd,'.',jTileStart,'-',jTileEnd - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - - iPoint = 1 - do j=1,ny - do i=1,nx - lat_pt = -89.99583 + (jTileStart + j - 2) * 0.0083333333 - lon_pt = -179.99583 + (iTileStart + i - 2) * 0.0083333333 - lat_pt = lat_pt * PI / 180.0 - lon_pt = lon_pt * PI / 180.0 - - iPoint = nearest_cell(lat_pt,lon_pt,iPoint,nCells,maxEdges, & - nEdgesOnCell,cellsOnCell, & - latCell,lonCell) - ncat(int(rarray(i,j,1)),iPoint) = ncat(int(rarray(i,j,1)),iPoint) + 1 - end do - end do + geog_sub_path = 'soiltype_top_30s/' - end do - end do - - do iCell = 1,nCells - soilcat_top(iCell) = 1 - do i = 2,16 - if(ncat(i,iCell) > ncat(soilcat_top(iCell),iCell)) then - soilcat_top(iCell) = i - end if - end do - end do - deallocate(rarray) - deallocate(ncat) + call mpas_log_write('--- start interpolate SOILCAT_TOP') + 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') - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! KLUDGE TO FIX SOIL TYPE OVER ANTARCTICA !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -443,14 +428,14 @@ subroutine init_atm_static(mesh, dims, configs) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! do iCell = 1,nCells if (lu_index(iCell) == iswater_lu .or. & - soilcat_top(iCell) == 14) then + soilcat_top(iCell) == iswater_soil) then if (lu_index(iCell) /= iswater_lu) then call mpas_log_write('Turning lu_index into water at $i', intArgs=(/iCell/)) lu_index(iCell) = iswater_lu end if - if (soilcat_top(iCell) /= 14) then + if (soilcat_top(iCell) /= iswater_soil) then call mpas_log_write('Turning soilcat_top into water at $i', intArgs=(/iCell/)) - soilcat_top(iCell) = 14 + soilcat_top(iCell) = iswater_soil end if end if end do @@ -459,301 +444,1714 @@ subroutine init_atm_static(mesh, dims, configs) ! ! Derive LANDMASK ! - landmask(:) = 0 - do iCell=1, nCells - if (lu_index(iCell) /= iswater_lu) landmask(iCell) = 1 - end do + call mpas_log_write('--- start interpolate LANDMASK') + call derive_landmask(mesh, dims, iswater_lu) call mpas_log_write('--- end interpolate LANDMASK') ! ! Interpolate SOILTEMP: ! - nx = 186 - ny = 186 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 2 - scalefactor = 0.01 - allocate(rarray(nx,ny,nz)) - allocate(soiltemp_1deg(-2:363,-2:183)) - soiltemp(:) = 0.0 - - call map_set(PROJ_LATLON, proj, & - latinc = 1.0_RKIND, & - loninc = 1.0_RKIND, & - knowni = 1.0_RKIND, & - knownj = 1.0_RKIND, & - lat1 = -89.5_RKIND, & - lon1 = -179.5_RKIND) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'soiltemp_1deg/',1,'-',180,'.',1,'-',180 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned, endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - soiltemp_1deg(-2:180,-2:183) = rarray(1:183,1:186,1) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'soiltemp_1deg/',181,'-',360,'.',1,'-',180 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname, len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - soiltemp_1deg(181:363,-2:183) = rarray(4:186,1:186,1) - - interp_list(1) = FOUR_POINT - interp_list(2) = W_AVERAGE4 - interp_list(3) = W_AVERAGE16 - interp_list(4) = SEARCH - interp_list(5) = 0 - - do iCell = 1,nCells - - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - if(x < 0.5) then - lon = lon + 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - else if (x >= 360.5) then - lon = lon - 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - end if - if (y < 1.0) y = 1.0 - if (y > 179.0) y = 179.0 - soiltemp(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, & - 1,1,0.0_RKIND,interp_list,1) - else - soiltemp(iCell) = 0.0 - end if - - end do - deallocate(rarray) - deallocate(soiltemp_1deg) + call mpas_log_write('--- start interpolate SOILTEMP') + call interp_soiltemp(mesh, dims, configs) call mpas_log_write('--- end interpolate SOILTEMP') ! ! Interpolate SNOALB ! - nx = 186 - ny = 186 - nz = 1 - isigned = 0 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(maxsnowalb(-2:363,-2:183)) - snoalb(:) = 0.0 - - call map_set(PROJ_LATLON, proj, & - latinc = 1.0_RKIND, & - loninc = 1.0_RKIND, & - knowni = 1.0_RKIND, & - knownj = 1.0_RKIND, & - lat1 = -89.5_RKIND, & - lon1 = -179.5_RKIND) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'maxsnowalb/',1,'-',180,'.',1,'-',180 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - maxsnowalb(-2:180,-2:183) = rarray(1:183,1:186,1) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'maxsnowalb/',181,'-',360,'.',1,'-',180 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus, fname) - maxsnowalb(181:363,-2:183) = rarray(4:186,1:186,1) - - interp_list(1) = FOUR_POINT - interp_list(2) = W_AVERAGE4 - interp_list(3) = W_AVERAGE16 - interp_list(4) = SEARCH - interp_list(5) = 0 + if (trim(config_maxsnowalbedo_data) == 'MODIS') then - do iCell = 1,nCells - - if(landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - if(x < 0.5) then - lon = lon + 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - else if (x >= 360.5) then - lon = lon - 360.0 + geog_sub_path = 'maxsnowalb_modis/' + + call mpas_log_write('Using MODIS 0.05-deg data for maximum snow albedo') + if (supersample_fac > 1) then + call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac/)) + end if + + ierr = mgr % init(trim(geog_data_path)//trim(geog_sub_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initializing the interpolation of snow albedo (snoalb)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor_ptr) + scalefactor = scalefactor_ptr + + allocate(nhs(nCells)) + allocate(snoalb_integer(nCells)) + snoalb_integer(:) = 0 + snoalb(:) = 0.0 + nhs(:) = 0 + fillval = 0.0 + + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) + end if + end if + + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + do j = supersample_fac * tile_bdr + 1, supersample_fac * (tile_ny + tile_bdr), 1 + do i = supersample_fac * tile_bdr + 1, supersample_fac * (tile_nx + tile_bdr), 1 + + ii = (i - 1) / supersample_fac + 1 + jj = (j - 1) / supersample_fac + 1 + + i8val = int(tile % tile(ii, jj, 1), kind=I8KIND) + + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt, supersample_fac) + 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) + + if (.not. associated(res)) cycle + + if (bdyMaskCell(res % id) < nBdyLayers) then + ! + ! This field only matters for land cells, and for all but the outermost boundary cells, + ! we can safely assume that the nearest model grid cell contains the pixel (else, a different + ! cell would be nearest). + ! + ! Since values in i8val are not yet scaled, we can compare them to missing_value, which + ! also is not scaled, without scaling either value + if (landmask(res % id) == 1 .and. i8val /= int(missing_value, kind=I8KIND)) then + snoalb_integer(res % id) = snoalb_integer(res % id) + i8val + nhs(res % id) = nhs(res % id) + 1 + end if + + ! + ! When a pixel maps to a non-land cell or is a missing value, the values are not accumulated + ! above; however, these pixels may still reside in an owned cell, in which case we will still need + ! to push the tile's neighbors onto the stack for processing. + ! + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + ! For outermost cells, additional work is needed to verify that the pixel + ! actually lies within the nearest cell + else + 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 + + ! Since values in i8val are not yet scaled, we can compare them to missing_value, which + ! also is not scaled, without scaling either value + if (landmask(res % id) == 1 .and. i8val /= int(missing_value, kind=I8KIND)) then + snoalb_integer(res % id) = snoalb_integer(res % id) + i8val + nhs(res % id) = nhs(res % id) + 1 + end if + + ! + ! When a pixel maps to a non-land cell or is a missing value, the values are not accumulated + ! above; however, these pixels may still reside in an owned cell, in which case we will still need + ! to push the tile's neighbors onto the stack for processing. + ! + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if + end do + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing the tile neighbors of: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) + end if + end if + end do + end do + + do iCell = 1, nCells + ! + ! Mismatches in land mask can lead to MPAS land points with no maximum snow albedo. + ! Ideally, we would perform a search for nearby valid albedos, but for now using + ! the fill value will at least allow the model to run. In general, the number of cells + ! to be treated in this way tends to be a very small fraction of the total number of cells. + ! + if (nhs(iCell) == 0) then + snoalb(iCell) = fillval + else + snoalb(iCell) = real(real(snoalb_integer(iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + snoalb(iCell) = snoalb(iCell) * scalefactor + snoalb(iCell) = 0.01_RKIND * snoalb(iCell) ! Convert from percent to fraction + endif + end do + + deallocate(nhs) + deallocate(snoalb_integer) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of snow albedo (snoalb)', & + messageType=MPAS_LOG_CRIT) + endif + + else if (trim(config_maxsnowalbedo_data) == 'NCEP') then + + call mpas_log_write('Using NCEP 1.0-deg data for maximum snow albedo') + + nx = 186 + ny = 186 + nz = 1 + isigned = 0 + endian = 0 + wordsize = 1 + scalefactor = 1.0 + allocate(rarray(nx,ny,nz)) + allocate(maxsnowalb(-2:363,-2:183)) + snoalb(:) = 0.0 + + rarray_ptr = c_loc(rarray) + + call map_set(PROJ_LATLON, proj, & + latinc = 1.0_RKIND, & + loninc = 1.0_RKIND, & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = -89.5_RKIND, & + lon1 = -179.5_RKIND) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'maxsnowalb/',1,'-',180,'.',1,'-',180 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + maxsnowalb(-2:180,-2:183) = rarray(1:183,1:186,1) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'maxsnowalb/',181,'-',360,'.',1,'-',180 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus, fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + maxsnowalb(181:363,-2:183) = rarray(4:186,1:186,1) + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = W_AVERAGE16 + interp_list(4) = SEARCH + interp_list(5) = 0 + + do iCell = 1,nCells + + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= 360.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 1.0) y = 1.0 + if (y > 179.0) y = 179.0 + snoalb(iCell) = interp_sequence(x,y,1,maxsnowalb,-2,363,-2,183, & + 1,1,0.0_RKIND,interp_list,1) + else + snoalb(iCell) = 0.0 end if - if (y < 1.0) y = 1.0 - if (y > 179.0) y = 179.0 - snoalb(iCell) = interp_sequence(x,y,1,maxsnowalb,-2,363,-2,183, & - 1,1,0.0_RKIND,interp_list,1) - else - snoalb(iCell) = 0.0 - end if - end do - snoalb(:) = snoalb(:) / 100.0 - deallocate(rarray) - deallocate(maxsnowalb) + end do + snoalb(:) = snoalb(:) / 100.0 + deallocate(rarray) + deallocate(maxsnowalb) + + else + + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Invalid maximum snow albedo dataset '''//trim(config_maxsnowalbedo_data) & + //''' selected for config_maxsnowalbedo_data', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Possible options are: ''MODIS'', ''NCEP''', messageType=MPAS_LOG_ERR) + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) + + end if + call mpas_log_write('--- end interpolate SNOALB') ! ! Interpolate GREENFRAC ! - nx = 1256 - ny = 1256 - nz = 12 - isigned = 0 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(vegfra(-2:2503,-2:1253,12)) - greenfrac(:,:) = 0.0 - - call map_set(PROJ_LATLON, proj, & - latinc = 0.144_RKIND, & - loninc = 0.144_RKIND, & - knowni = 1.0_RKIND, & - knownj = 1.0_RKIND, & - lat1 = -89.928_RKIND, & - lon1 = -179.928_RKIND) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'greenfrac/',1,'-',1250,'.',1,'-',1250 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'greenfrac/',1251,'-',2500,'.',1,'-',1250 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) + if (trim(config_vegfrac_data) == 'MODIS') then - do iCell = 1,nCells + call mpas_log_write('Using MODIS FPAR 30-arc-second data for climatological monthly vegetation fraction') - if (landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - if(x < 0.5) then - lon = lon + 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - else if(x >= 2500.5) then - lon = lon - 360.0 + 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)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initalizing the interpolation of monthly vegetation fraction (greenfrac)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z', tile_nz) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + + allocate(nhs(nCells)) + allocate(greenfrac_int(tile_nz, nCells)) + nhs(:) = 0 + greenfrac(:,:) = 0.0 + greenfrac_int(:,:) = 0_I8KIND + fillval = 0.0 + + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile % fname), messageType=MPAS_LOG_CRIT) + end if + end if + + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + 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, 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) + + if (.not. associated(res)) cycle + + ! + ! This field only matters for land cells, and for all but the outermost boundary cells, + ! we can safely assume that the nearest model grid cell contains the pixel (else, a different + ! cell would be nearest) + ! + if (landMask(res % id) == 1 .and. bdyMaskCell(res % id) < nBdyLayers) then + do k = 1, tile_nz + if (tile % tile(ii, jj, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(ii, jj, k), kind=I8KIND) + end if + greenfrac_int(k, res % id) = greenfrac_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + + ! For outermost land cells, additional work is needed to verify that the pixel + ! actually lies within the nearest cell + else if (landMask(res % id) == 1) then + 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(ii, jj, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(ii, jj, k), kind=I8KIND) + end if + greenfrac_int(k, res % id) = greenfrac_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if + end do + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing the tile neighbors of: "//trim(tile%fname), messageType=MPAS_LOG_CRIT) + end if + end if + + end do + end do + + do iCell = 1, nCells + ! For land points that have no overlap with valid data, and for water points, + ! just use the fill value... + if (nhs(iCell) == 0) then + greenfrac(:,iCell) = fillval + else + greenfrac(:,iCell) = real(real(greenfrac_int(:,iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + end if + shdmin(iCell) = minval(greenfrac(:,iCell)) + shdmax(iCell) = maxval(greenfrac(:,iCell)) + end do + + deallocate(nhs) + deallocate(greenfrac_int) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of monthly vegetation fraction (greenfrac)', & + messageType=MPAS_LOG_CRIT) + endif + + else if (trim(config_vegfrac_data) == 'NCEP') then + + call mpas_log_write('Using NCEP 0.144-deg data for climatological monthly vegetation fraction') + + nx = 1256 + ny = 1256 + nz = 12 + isigned = 0 + endian = 0 + wordsize = 1 + scalefactor = 1.0 + allocate(rarray(nx,ny,nz)) + allocate(vegfra(-2:2503,-2:1253,12)) + greenfrac(:,:) = 0.0 + + rarray_ptr = c_loc(rarray) + + call map_set(PROJ_LATLON, proj, & + latinc = 0.144_RKIND, & + loninc = 0.144_RKIND, & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = -89.928_RKIND, & + lon1 = -179.928_RKIND) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'greenfrac/',1,'-',1250,'.',1,'-',1250 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'greenfrac/',1251,'-',2500,'.',1,'-',1250 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) + + do iCell = 1,nCells + + if (landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if(x >= 2500.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 1.0) y = 1.0 + if (y > 1249.0) y = 1249.0 + do k = 1,12 + greenfrac(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & + 1,12,-1.e30_RKIND,interp_list,1) + end do + else + greenfrac(:,iCell) = 0.0 end if - if (y < 1.0) y = 1.0 - if (y > 1249.0) y = 1249.0 - do k = 1,12 - greenfrac(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & - 1,12,-1.e30_RKIND,interp_list,1) - end do - else - greenfrac(:,iCell) = 0.0 - end if - shdmin(iCell) = minval(greenfrac(:,iCell)) - shdmax(iCell) = maxval(greenfrac(:,iCell)) - - end do - deallocate(rarray) - deallocate(vegfra) + shdmin(iCell) = minval(greenfrac(:,iCell)) + shdmax(iCell) = maxval(greenfrac(:,iCell)) + + end do + deallocate(rarray) + deallocate(vegfra) + + else + + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Invalid monthly vegetation fraction dataset '''//trim(config_vegfrac_data) & + //''' selected for config_vegfrac_data', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Possible options are: ''MODIS'', ''NCEP''', messageType=MPAS_LOG_ERR) + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) + + end if + call mpas_log_write('--- end interpolate GREENFRAC') ! ! Interpolate ALBEDO12M ! - nx = 1256 - ny = 1256 - nz = 12 - isigned = 0 - endian = 0 - wordsize = 1 - scalefactor = 1.0 - allocate(rarray(nx,ny,nz)) - allocate(vegfra(-2:2503,-2:1253,12)) - albedo12m(:,:) = 0.0 - - call map_set(PROJ_LATLON, proj, & - latinc = 0.144_RKIND, & - loninc = 0.144_RKIND, & - knowni = 1.0_RKIND, & - knownj = 1.0_RKIND, & - lat1 = -89.928_RKIND, & - lon1 = -179.928_RKIND) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'albedo_ncep/',1,'-',1250,'.',1,'-',1250 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor, wordsize, istatus) - call init_atm_check_read_error(istatus,fname) - vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) - - write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & - 'albedo_ncep/',1251,'-',2500,'.',1,'-',1250 - call mpas_log_write(trim(fname)) - - call read_geogrid(fname,len_trim(fname),rarray,nx,ny,nz,isigned,endian, & - scalefactor,wordsize,istatus) - call init_atm_check_read_error(istatus,fname) - vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) + if (trim(config_albedo_data) == 'MODIS') then - do iCell = 1,nCells + call mpas_log_write('Using MODIS 0.05-deg data for climatological monthly albedo') + if (supersample_fac > 1) then + call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac/)) + end if - if (landmask(iCell) == 1) then - lat = latCell(iCell) * DEG_PER_RAD - lon = lonCell(iCell) * DEG_PER_RAD - call latlon_to_ij(proj, lat, lon, x, y) - if(x < 0.5) then - lon = lon + 360.0 - call latlon_to_ij(proj, lat, lon, x, y) - else if(x >= 2500.5) then - lon = lon - 360.0 + geog_sub_path = 'albedo_modis/' + + ierr = mgr % init(trim(geog_data_path)//trim(geog_sub_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred when initalizing the interpolation of monthly albedo (albedo12m)', & + messageType=MPAS_LOG_CRIT) + endif + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor_ptr) + scalefactor = scalefactor_ptr + + allocate(albedo12m_int(tile_z_start:tile_z_end, nCells)) + allocate(nhs(nCells)) + albedo12m_int(:,:) = 0 + albedo12m(:,:) = 0.0 + nhs(:) = 0 + fillval = 8.0 + + do iCell = 1, nCells + if (nhs(iCell) == 0) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_CRIT) + end if + + ierr = mgr % push_tile(tile) + if (ierr /= 0) then + call mpas_log_write("Error pushing this tile onto the stack: "//trim(tile % fname), messageType=MPAS_LOG_CRIT) + end if + end if + + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + + all_pixels_mapped_to_halo_cells = .true. + + do j = supersample_fac * tile_bdr + 1, supersample_fac * (tile_ny + tile_bdr), 1 + do i = supersample_fac * tile_bdr + 1, supersample_fac * (tile_nx + tile_bdr), 1 + + ii = (i - 1) / supersample_fac + 1 + jj = (j - 1) / supersample_fac + 1 + + call mgr % tile_to_latlon(tile, j, i, lat_pt, lon_pt, supersample_fac) + 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) + + if (.not. associated(res)) cycle + + if (bdyMaskCell(res % id) < nBdyLayers) then + if (landMask(res % id) == 1) then + do k = tile_z_start, tile_z_end + if (tile % tile(ii, jj, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(ii,jj,k), kind=I8KIND) + end if + albedo12m_int(k, res % id) = albedo12m_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + end if + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + else + 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 + if (landMask(res % id) == 1) then + do k = tile_z_start, tile_z_end + if (tile % tile(ii, jj, k) == missing_value) then + i8val = int(fillval, kind=I8KIND) + else + i8val = int(tile % tile(ii,jj,k), kind=I8KIND) + end if + albedo12m_int(k, res % id) = albedo12m_int(k, res % id) + i8val + end do + nhs(res % id) = nhs(res % id) + 1 + end if + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end if + end if + end do + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + if (ierr /= 0) then + call mpas_log_write("error pushing the tile neighbors of: "//trim(tile%fname), messagetype=MPAS_LOG_CRIT) + end if + end if + + end do + end do + + do iCell = 1, nCells + if (nhs(iCell) == 0) then + albedo12m(:,iCell) = fillVal + else + albedo12m(:,iCell) = real(real(albedo12m_int(:,iCell), kind=R8KIND) / real(nhs(iCell), kind=R8KIND), kind=RKIND) + albedo12m(:,iCell) = albedo12m(:,iCell) * scalefactor + end if + if (lu_index(iCell) == isice_lu) then + albedo12m(:,iCell) = 70.0 ! TODO: Where does this come from? + endif + end do + + deallocate(nhs) + deallocate(albedo12m_int) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred when finalizing the interpolation of monthly albedo (albedo12m)', & + messageType=MPAS_LOG_CRIT) + endif + + else if (trim(config_albedo_data) == 'NCEP') then + + call mpas_log_write('Using NCEP 0.144-deg data for climatological monthly albedo') + + nx = 1256 + ny = 1256 + nz = 12 + isigned = 0 + endian = 0 + wordsize = 1 + scalefactor = 1.0 + allocate(rarray(nx,ny,nz)) + allocate(vegfra(-2:2503,-2:1253,12)) + albedo12m(:,:) = 0.0 + + rarray_ptr = c_loc(rarray) + + call map_set(PROJ_LATLON, proj, & + latinc = 0.144_RKIND, & + loninc = 0.144_RKIND, & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = -89.928_RKIND, & + lon1 = -179.928_RKIND) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'albedo_ncep/',1,'-',1250,'.',1,'-',1250 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize, istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + vegfra(-2:1250,-2:1253,1:12) = rarray(1:1253,1:1256,1:12) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'albedo_ncep/',1251,'-',2500,'.',1,'-',1250 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + vegfra(1251:2503,-2:1253,1:12) = rarray(4:1256,1:1256,1:12) + + do iCell = 1,nCells + + if (landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD call latlon_to_ij(proj, lat, lon, x, y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if(x >= 2500.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 1.0) y = 1.0 + if (y > 1249.0) y = 1249.0 + do k = 1,12 + albedo12m(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & + 1,12,0.0_RKIND,interp_list,1) + end do + else + albedo12m(:,iCell) = 8.0 end if - if (y < 1.0) y = 1.0 - if (y > 1249.0) y = 1249.0 - do k = 1,12 - albedo12m(k,iCell) = interp_sequence(x,y,k,vegfra,-2,2503,-2,1253, & - 1,12,0.0_RKIND,interp_list,1) - end do - else - albedo12m(:,iCell) = 8.0 - end if - end do - deallocate(rarray) - deallocate(vegfra) + end do + deallocate(rarray) + deallocate(vegfra) + + else + + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Invalid monthly albedo dataset '''//trim(config_albedo_data) & + //''' selected for config_albedo_data', messageType=MPAS_LOG_ERR) + call mpas_log_write(' Possible options are: ''MODIS'', ''NCEP''', messageType=MPAS_LOG_ERR) + call mpas_log_write('*****************************************************************', messageType=MPAS_LOG_ERR) + call mpas_log_write('Please correct the namelist.', messageType=MPAS_LOG_CRIT) + + end if + call mpas_log_write('--- end interpolate ALBEDO12M') +! +! Interpolate SOILCOMP +! + geog_sub_path = 'soilgrids/soilcomp/' + call mpas_log_write('--- start interpolate SOILCOMP') + call interp_soilcomp(mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCOMP') + +! +! Interpolate SOILCL1 +! + geog_sub_path = 'soilgrids/texture_layer1/' + + call mpas_log_write('--- start interpolate SOILCL1') + call interp_soil_texture('soilcl1', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL1') + +! +! Interpolate SOILCL2 +! + geog_sub_path = 'soilgrids/texture_layer2/' + + call mpas_log_write('--- start interpolate SOILCL2') + call interp_soil_texture('soilcl2', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL2') + +! +! Interpolate SOILCL3 +! + geog_sub_path = 'soilgrids/texture_layer3/' + + call mpas_log_write('--- start interpolate SOILCL3') + call interp_soil_texture('soilcl3', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL3') + +! +! Interpolate SOILCL4 +! + geog_sub_path = 'soilgrids/texture_layer4/' + + call mpas_log_write('--- start interpolate SOILCL4') + call interp_soil_texture('soilcl4', mesh, tree, trim(geog_data_path)//trim(geog_sub_path), & + supersample_fac=supersample_fac_30s) + call mpas_log_write('--- end interpolate SOILCL4') + + +! +! Deallocate and free the KD Tree +! + call mpas_kd_free(tree) + deallocate(kd_points) + end subroutine init_atm_static + + !*********************************************************************** + ! + ! routine init_atm_map_static_data + ! + !> \brief Map values of static datasets to cells + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Given a initialized geotile manager object, an initialized KD tree of cell centers + !> (xCell, yCell, zCell), and two function pointers, this subroutine maps pixels of a + !> Geogrid binary format dataset to the cells they reside in. The geogrid binary format + !> is described in Chapter 3 of the WRF User's Guide. Because this routine uses a K-Dimensional + !> tree to map pixels to cells, it can safely map datasets to MPAS meshes in parallel. + !> + !> The interp_criteria procedure will need to match the interp_criteria_function abstract + !> interface. The procedure is used to determine if the tile that contains iCell has been + !> processed or not. If it has not, then the tile will be added to the process stack for + !> processing. If a cell has not received any mappings than it is possible the tile that + !> contains that cell has not processed. In that case, the function should return .true. to add + !> the tile to the stack. A value of .false. will signify that the cell has received values, and + !> thus, that the tile that contains that cell does not need to be processed. Different datasets + !> may need to implement this function differently (e.g. continuous vs categorical). + !> + !> The accumulation_method procedure will be called with the mappings between pixel values + !> and the cells in which they map to. Currently, the accumulation_method does not need to + !> return any values. + !> + !> If supersample_fac is present each pixel will be subdivided into supersampel_fac ^ 2 + !> sub-pixels. + ! + !----------------------------------------------------------------------- + subroutine init_atm_map_static_data(mesh, mgr, kdtree, interp_criteria, accumulation_method, supersample_fac) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(in) :: mesh + type (mpas_geotile_mgr_type), intent(in) :: mgr + type (mpas_kd_type), pointer, intent(in) :: kdtree + procedure (interp_criteria_function) :: interp_criteria + procedure (interp_accumulation_function) :: accumulation_method + integer, intent(in), optional :: supersample_fac + + ! Local variables + integer, pointer :: nCells + integer, pointer :: nCellsSolve + integer, dimension(:), pointer :: bdyMaskCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: verticesOnCell + real (kind=RKIND), dimension(:), pointer :: xCell, yCell, zCell + real (kind=RKIND), dimension(:), pointer :: xVertex, yVertex, zVertex + real (kind=RKIND), pointer :: sphere_radius + real (kind=RKIND), dimension(:), pointer :: latCell, lonCell + + integer, pointer :: tile_bdr + integer, pointer :: tile_nx, tile_ny + integer, pointer :: tile_z_start, tile_z_end + integer :: supersample_fac_lcl + integer :: subsample_fac + + real (kind=RKIND) :: lat + real (kind=RKIND) :: lon + real (kind=RKIND) :: xPixel, yPixel, zPixel + real (kind=RKIND), pointer :: scale_factor + + integer :: iCell + integer :: i, ii + integer :: j, jj + + logical :: all_pixels_mapped_to_halo_cells + + type (mpas_geotile_type), pointer :: tile + type (mpas_kd_type), pointer :: res + + integer :: ierr + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nCellsSolve', nCellsSolve) + call mpas_pool_get_config(mesh, 'sphere_radius', sphere_radius) + + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + call mpas_pool_get_array(mesh, 'xCell', xCell) + call mpas_pool_get_array(mesh, 'yCell', yCell) + call mpas_pool_get_array(mesh, 'zCell', zCell) + call mpas_pool_get_array(mesh, 'xVertex', xVertex) + call mpas_pool_get_array(mesh, 'yVertex', yVertex) + call mpas_pool_get_array(mesh, 'zVertex', zVertex) + call mpas_pool_get_array(mesh, 'nEdgesOnCell', nEdgesOnCell) + call mpas_pool_get_array(mesh, 'verticesOnCell', verticesOnCell) + call mpas_pool_get_array(mesh, 'bdyMaskCell', bdyMaskCell) + + call mpas_pool_get_config(mgr % pool, 'tile_bdr', tile_bdr) + call mpas_pool_get_config(mgr % pool, 'tile_x', tile_nx) + call mpas_pool_get_config(mgr % pool, 'tile_y', tile_ny) + call mpas_pool_get_config(mgr % pool, 'tile_z_start', tile_z_start) + call mpas_pool_get_config(mgr % pool, 'tile_z_end', tile_z_end) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scale_factor) + + if (present(supersample_fac)) then + supersample_fac_lcl = supersample_fac + else + supersample_fac_lcl = 1 + end if + + if (supersample_fac_lcl > 1) then + call mpas_log_write(' Dataset will be supersampled by a factor of $i', intArgs=(/supersample_fac_lcl/)) + end if + + ! Subsample_fac should always be 1, else datasets will not be fully interpolated. + subsample_fac = 1 + + do iCell = 1, nCells + ! + ! Insure all cells receive values by loading tiles that have not received values and + ! pushing them onto the stack. + ! + if (interp_criteria(iCell)) then + tile => null() + ierr = mgr % get_tile(latCell(iCell), lonCell(iCell), tile) + if (ierr /= 0 .or. .not. associated(tile)) then + call mpas_log_write('Could not get tile that contained cell $i', intArgs=(/iCell/), messageType=MPAS_LOG_ERR) + return + end if + ierr = mgr % push_tile(tile) + end if + + ! + ! Process each tile by removing it from the stack. Determine the closest cell center to each tile + ! pixel by using a KD search and pass the pixel value and the closest cell center id to the + ! accumulation routine. + ! + do while (.not. mgr % is_stack_empty()) + tile => mgr % pop_tile() + + if (tile % is_processed) then + cycle + end if + + call mpas_log_write('Processing tile: '//trim(tile % fname)) + all_pixels_mapped_to_halo_cells = .true. + + do j = supersample_fac_lcl * tile_bdr + 1, supersample_fac_lcl * (tile_ny + tile_bdr), subsample_fac + do i = supersample_fac_lcl * tile_bdr + 1, supersample_fac_lcl * (tile_nx + tile_bdr), subsample_fac + + ! Supersample coordinates + ii = (i - 1) / supersample_fac_lcl + 1 + jj = (j - 1) / supersample_fac_lcl + 1 + + call mgr % tile_to_latlon(tile, j, i, lat, lon, supersample_fac_lcl) + call mpas_latlon_to_xyz(xPixel, yPixel, zPixel, sphere_radius, lat, lon) + call mpas_kd_search(kdtree, (/xPixel, yPixel, zPixel/), res, max_distance=max_kdtree_distance2) + + if (.not. associated(res)) cycle + + ! + ! For outermost boundary cells, extra work is needed to be done to determine if a pixel actually + ! lies within the cell returned by mpas_kd_search + ! + if (bdyMaskCell(res % id) == nBdyLayers) then + ! mpas_in_cell could be included in the if statement above, but calling it is expensive and the Fortran + ! standard does not require compilers to short circuit compound conditionals. + if (.not. 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 + ! + ! This pixel lies outside of res % cell and outside of the limited-area region, no further processing is + ! needed + ! + cycle + end if + end if + + ! + ! Send the entire pixel column to the accumulation method + ! + call accumulation_method(res % id, int(tile % tile(ii,jj,:), kind=I8KIND)) + + if (res % id <= nCellsSolve) then + all_pixels_mapped_to_halo_cells = .false. + end if + end do + end do + + tile % is_processed = .true. + deallocate(tile % tile) + + ! + ! If at least one pixel maps to an owned cell (i.e. <= nCellsSolve) then + ! it is possible that the neighboring tiles might contain pixels that map + ! to this process' compute cells, so add them to the stack. + ! + if (.not. all_pixels_mapped_to_halo_cells) then + ierr = mgr % push_neighbors(tile) + end if + end do + end do + + end subroutine init_atm_map_static_data + + +!-------------------------------------------------------------------------------------------------- +! Terrain interpolation +!-------------------------------------------------------------------------------------------------- + + !*********************************************************************** + ! + ! routine continuous_interp_criteria + ! + !> \brief Continuous dataset interpolation criteria + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine can be used to determine if the tile that contains iCell needs + !> to be loaded and processed by init_atm_map_static_data for continuous datasets. + ! + !----------------------------------------------------------------------- + function continuous_interp_criteria(iCell) + + integer, intent(in) :: iCell + logical :: continuous_interp_criteria + + continuous_interp_criteria = .false. + + if (nhs(iCell) == 0) then + continuous_interp_criteria = .true. + end if + + end function continuous_interp_criteria + + + !*********************************************************************** + ! + ! routine terrain_interp_accumulation + ! + !> \brief Accumulate terrain dataset values + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine accumulates terrain values for the init_atm_map_static_data unified + !> function. + ! + !----------------------------------------------------------------------- + subroutine terrain_interp_accumulation(iCell, pixel) + + integer, intent(in) ::iCell + integer (kind=I8KIND), dimension(:), intent(in) :: pixel + + ter_integer(iCell) = ter_integer(iCell) + int(pixel(1), kind=I8KIND) + nhs(iCell) = nhs(iCell) + 1 + + end subroutine terrain_interp_accumulation + + + !*********************************************************************** + ! + ! routine soilcomp_interp_accumulation + ! + !> \brief Accumulate soilcomp dataset values + !> \author Michael G. Duda + !> \date 31 May 2024 + !> \details + !> This routine accumulates soilcomp values for the init_atm_map_static_data + !> routine. + ! + !----------------------------------------------------------------------- + subroutine soilcomp_interp_accumulation(iCell, pixel) + + integer, intent(in) ::iCell + integer (kind=I8KIND), dimension(:), intent(in) :: pixel + + if (landmask(iCell) == 0) return + + if (pixel(1) /= soilcomp_msgval) then + soilcomp_int(:,iCell) = soilcomp_int(:,iCell) + int(pixel(:), kind=I8KIND) + nhs(iCell) = nhs(iCell) + 1 + end if + + end subroutine soilcomp_interp_accumulation + + + !*********************************************************************** + ! + ! routine interp_terrain + ! + !> \brief Interpolate terrain + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Interpolate terrain by using the init_atm_map_static_data routine and + !> accumulating pixel values into cells using terrain_interp_accumulation. + !> mesh, should be a mpas_pool that contains ter and the nCells dimension. kdtree + !> should be a initialized kdtree of (xCell, yCell, zCell), and geog_data_path + !> should be the path to the terrain dataset. + ! + !----------------------------------------------------------------------- + subroutine interp_terrain(mesh, kdtree, geog_data_path, supersample_fac) + + implicit none + + ! Input variables + 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 + integer, pointer :: nCells + + real (kind=RKIND), dimension(:), pointer :: ter + + real (kind=RKIND), pointer :: scalefactor + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occurred initializing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'ter', ter) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + + allocate(ter_integer(nCells)) + allocate(nhs(nCells)) + + ! + ! Store tile values as a I8KIND integer temporarily to avoid floating + ! point round off differences and to have +/- 9.22x10^18 range of representative + ! values. For example, a 120 km mesh with a 1 meter data set with 6 decimal of + ! precision will allow for values of 180x10^12. + ! + ter(:) = 0.0 + ter_integer(:) = 0 + nhs(:) = 0 + + 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) + ter(iCell) = ter(iCell) * scalefactor + end do + + deallocate(ter_integer) + deallocate(nhs) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write("Error occurred finalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + end subroutine interp_terrain + + !*********************************************************************** + ! + ! routine interp_soilcomp + ! + !> \brief Interpolate the soilcomp field for Noah-MP + !> \author Michael G. Duda + !> \date 31 May 2024 + !> \details + !> Interpolate soilcomp using the init_atm_map_static_data routine, + !> accumulating pixel values into cells using the soilcomp_interp_accumulation + !> method. + !> + !> The mesh argument is an mpas_pool that contains soilcomp as well as + !> the nCells dimension. kdtree is an initialized kdtree of (xCell, yCell, zCell), + !> and geog_data_path specifies the path to the soilcomp dataset. + !> + !> The supersample_fac argument specifies the supersampling factor to be + !> applied to the source dataset. + ! + !----------------------------------------------------------------------- + subroutine interp_soilcomp(mesh, kdtree, geog_data_path, supersample_fac) + + implicit none + + ! Input variables + 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 + integer, pointer :: nCells, nSoilComps + real (kind=RKIND), pointer :: scalefactor + real (kind=RKIND), pointer :: missing_value + + real (kind=RKIND), dimension(:,:), pointer :: soilcomp + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write('Error occurred initializing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + + return ! Program execution should not reach this statement + ! since the preceding message is a critical error + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_dimension(mesh, 'nSoilComps', nSoilComps) + call mpas_pool_get_array(mesh, 'soilcomp', soilcomp) + + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'missing_value', missing_value) + + soilcomp_msgval = missing_value + + allocate(soilcomp_int(nSoilComps,nCells)) + allocate(nhs(nCells)) + + ! + ! Store tile values as a I8KIND integer temporarily to avoid floating + ! point round off differences and to have +/- 9.22x10^18 range of representative + ! values. For example, a 120 km mesh with a 1 meter data set with 6 decimal of + ! precision will allow for values of 180x10^12. + ! + soilcomp(:,:) = 0.0 + soilcomp_int(:,:) = 0 + nhs(:) = 0 + + call init_atm_map_static_data(mesh, mgr, kdtree, continuous_interp_criteria, & + soilcomp_interp_accumulation, & + supersample_fac=supersample_fac) + + do iCell = 1, nCells + if (nhs(iCell) > 0) then + soilcomp(:,iCell) = real(real(soilcomp_int(:,iCell), kind=R8KIND) & + / real(nhs(iCell), kind=R8KIND), kind=RKIND) + end if + end do + soilcomp(:,:) = soilcomp(:,:) * scalefactor + + deallocate(soilcomp_int) + deallocate(nhs) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occurred finalizing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + + return ! Program execution should not reach this statement + ! since the preceding message is a critical error + end if + + end subroutine interp_soilcomp + +!-------------------------------------------------------------------------------------------------- +! Categorical interpolations - Landuse and Soiltype +!-------------------------------------------------------------------------------------------------- + + !*********************************************************************** + ! + ! routine categorical_interp_criteria + ! + !> \brief Categorical dataset interp criteria + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine can be used to determine if the tile that contains iCell needs + !> to be loaded and processed by init_atm_map_static_data for categorical datasets. + ! + !----------------------------------------------------------------------- + function categorical_interp_criteria(iCell) + + integer, intent(in) :: iCell + logical :: categorical_interp_criteria + + categorical_interp_criteria = .false. + + if (all(ncat(:,iCell) == 0)) then + categorical_interp_criteria = .true. + end if + + end function categorical_interp_criteria + + !*********************************************************************** + ! + ! routine categorical_interp_accumulation + ! + !> \brief Accumulate categorical dataset values + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> This routine accumulates categorical values for the init_atm_map_static_data unified + !> function. + ! + !----------------------------------------------------------------------- + subroutine categorical_interp_accumulation(iCell, cat) + + integer, intent(in) :: iCell + integer (kind=I8KIND), dimension(:), intent(in) :: cat + ! Use the module level category_min and category_max variables + + ! + ! Currently, the MODIS landuse dataset has zeros at the South Pole, and possibly other + ! places, so we need a check on the validity of the category to be accumulated. + ! + if (cat(1) >= category_min .and. cat(1) <= category_max) then + ncat(cat(1), iCell) = ncat(cat(1), iCell) + 1 + end if + + end subroutine categorical_interp_accumulation + + !*********************************************************************** + ! + ! routine interp_landuse + ! + !> \brief Interpolate landuse + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Interpolate landuse by using the init_atm_map_static_data routine and + !> accumulating the pixel values into each cell using categorical_interp_accumulation. + !> + !> mesh should be a mpas_pool that contains nCells and lu_index, kdtree should be an + !> initialized mpas_kd_type tree with (xCell, yCell, zCell), and geog_data_path + !> should be the path to the landuse dataset. The values used by this dataset to + !> specify water and ice values will be set in isice_lu, iswater_lu, assuming + !> that isice and iswater are in the dataset's index file. + ! + !----------------------------------------------------------------------- + subroutine interp_landuse(mesh, kdtree, geog_data_path, isice_lu, iswater_lu, supersample_fac) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_kd_type), pointer, intent(in) :: kdtree + 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 + integer, pointer :: nCells + integer, pointer :: isice_lu_ptr + integer, pointer :: iswater_lu_ptr + + real (kind=RKIND), pointer :: scalefactor + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occured initalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + call mpas_pool_get_config(mgr % pool, 'isice', isice_lu_ptr) + call mpas_pool_get_config(mgr % pool, 'iswater', iswater_lu_ptr) + + isice_lu = isice_lu_ptr + iswater_lu = iswater_lu_ptr + + allocate(ncat(category_min:category_max, nCells)) + ncat(:,:) = 0 + + 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 + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + lu_index(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + end do + deallocate(ncat) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write("Error occured finalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return ! Program execution should not reach this statement since the preceding message is a critical error + end if + + nullify(category_min) + nullify(category_max) + + end subroutine interp_landuse + + !*********************************************************************** + ! + ! routine interp_soilcat + ! + !> \brief Interpolate soiltop category + !> \author Miles Curry + !> \date 25 January 2020 + !> \details + !> Interpolate soil category top by using the init_atm_map_static_data routine and + !> accumulating the pixel values into each cell using category_interp_accumulation. + !> + !> mesh should be an mpas_pool that contains and lu_index, kdtree should be an + !> initialized mpas_kd_type tree with (xCell, yCell, zCell), and geog_data_path + !> should be the path to the landuse dataset.The values used by this dataset to + !> signify water will be set in iswater_soil, assuming that + !> iswater is present in the dataset's index file. + !> + !----------------------------------------------------------------------- + subroutine interp_soilcat(mesh, kdtree, geog_data_path, iswater_soil, supersample_fac) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + 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 + integer, pointer :: nCells + integer, pointer :: iswater_soil_ptr + + real (kind=RKIND), pointer :: scalefactor + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write("Error occured initalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'soilcat_top', soilcat_top) + call mpas_pool_get_config(mgr % pool, 'scale_factor', scalefactor) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + call mpas_pool_get_config(mgr % pool, 'isoilwater', iswater_soil_ptr) + + iswater_soil = iswater_soil_ptr + + allocate(ncat(category_min:category_max, nCells)) + ncat(:,:) = 0 + + 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 + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + soilcat_top(iCell) = maxloc(ncat(:,iCell), dim=1) - 1 + category_min + end do + deallocate(ncat) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write("Error occured finalizing interpolation for "//trim(geog_data_path), messageType=MPAS_LOG_CRIT) + return + end if + + nullify(category_min) + nullify(category_max) + + end subroutine interp_soilcat + + !*********************************************************************** + ! + ! routine derive_landmask + ! + !> \brief Derive the landmask field + !> \details + !> Derive the landmask field from lu_index. mesh should be an mpas_pool + !> that contains landmask, and lu_index. iswater_lu should be the value that + !> the landuse dataset uses to signify water. Before calling this function, + !> the landuse dataset will need to be successfully interpolated to lu_index. + ! + !----------------------------------------------------------------------- + subroutine derive_landmask(mesh, dims, iswater_lu) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + integer, intent(in) :: iswater_lu + + ! Local variables + integer :: iCell + integer, pointer :: nCells + integer, dimension(:), pointer :: lu_index + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'landmask', landmask) + call mpas_pool_get_array(mesh, 'lu_index', lu_index) + + ! + ! Derive LANDMASK + ! + landmask(:) = 0 + do iCell=1, nCells + if (lu_index(iCell) /= iswater_lu) landmask(iCell) = 1 + end do + + end subroutine derive_landmask + + !*********************************************************************** + ! + ! routine interp_soiltemp + ! + !> \brief Interpolate soil temperature + !> \details + !> Interpolate soil temperature by using the soiltemp_1deg/ dataset. The mesh + !> pool should contain latCell, lonCell and soiltemp, dims should contain nCells, + !> and the configs pool should contain config_geog_data_path. + ! + !----------------------------------------------------------------------- + subroutine interp_soiltemp(mesh, dims, configs) + + implicit none + + ! Input variables + type (mpas_pool_type), intent(inout) :: mesh + type (mpas_pool_type), intent(in) :: dims + type (mpas_pool_type), intent(in) :: configs + + ! Local variables + type (proj_info) :: proj + character (len=StrKIND) :: fname + character (kind=c_char), dimension(StrKIND+1) :: c_fname + character(len=StrKIND), pointer :: config_geog_data_path + character(len=StrKIND+1) :: geog_data_path ! same as config_geog_data_path, but guaranteed to have a trailing slash + real (kind=c_float), dimension(:,:,:), pointer, contiguous :: rarray + real (kind=RKIND) :: scalefactor + real (kind=RKIND), dimension(:), pointer ::latCell, lonCell + real (kind=RKIND) :: lat, lon, x, y + real (kind=RKIND), dimension(:,:), allocatable :: soiltemp_1deg + real (kind=RKIND), dimension(:), pointer :: soiltemp + integer :: i, iCell + integer, pointer :: nCells + integer, dimension(5) :: interp_list + integer (c_int) :: endian, isigned, istatus, wordsize + integer (c_int) :: nx, ny, nz + type (c_ptr) :: rarray_ptr + + call mpas_pool_get_dimension(dims, 'nCells', nCells) + call mpas_pool_get_array(mesh, 'latCell', latCell) + call mpas_pool_get_array(mesh, 'lonCell', lonCell) + call mpas_pool_get_array(mesh, 'soiltemp', soiltemp) + call mpas_pool_get_config(configs, 'config_geog_data_path', config_geog_data_path) + + write(geog_data_path, '(a)') config_geog_data_path + i = len_trim(geog_data_path) + if (geog_data_path(i:i) /= '/') then + geog_data_path(i+1:i+1) = '/' + end if + + nx = 186 + ny = 186 + nz = 1 + isigned = 0 + endian = 0 + wordsize = 2 + scalefactor = 0.01 + allocate(rarray(nx,ny,nz)) + allocate(soiltemp_1deg(-2:363,-2:183)) + soiltemp(:) = 0.0 + + rarray_ptr = c_loc(rarray) + + call map_set(PROJ_LATLON, proj, & + latinc = 1.0_RKIND, & + loninc = 1.0_RKIND, & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = -89.5_RKIND, & + lon1 = -179.5_RKIND) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'soiltemp_1deg/',1,'-',180,'.',1,'-',180 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned, endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus, fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + soiltemp_1deg(-2:180,-2:183) = rarray(1:183,1:186,1) + + write(fname,'(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(geog_data_path)// & + 'soiltemp_1deg/',181,'-',360,'.',1,'-',180 + call mpas_log_write(trim(fname)) + call mpas_f_to_c_string(fname, c_fname) + + call read_geogrid(c_fname,rarray_ptr,nx,ny,nz,isigned,endian, & + wordsize,istatus) + call init_atm_check_read_error(istatus,fname) + rarray(:,:,:) = rarray(:,:,:) * real(scalefactor, kind=c_float) + soiltemp_1deg(181:363,-2:183) = rarray(4:186,1:186,1) + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = W_AVERAGE16 + interp_list(4) = SEARCH + interp_list(5) = 0 + + do iCell = 1,nCells + if(landmask(iCell) == 1) then + lat = latCell(iCell) * DEG_PER_RAD + lon = lonCell(iCell) * DEG_PER_RAD + call latlon_to_ij(proj, lat, lon, x, y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + else if (x >= 360.5) then + lon = lon - 360.0 + call latlon_to_ij(proj, lat, lon, x, y) + end if + if (y < 1.0) y = 1.0 + if (y > 179.0) y = 179.0 + soiltemp(iCell) = interp_sequence(x,y,1,soiltemp_1deg,-2,363,-2,183, & + 1,1,0.0_RKIND,interp_list,1) + else + soiltemp(iCell) = 0.0 + end if + + end do + deallocate(rarray) + deallocate(soiltemp_1deg) + + end subroutine interp_soiltemp + + !*********************************************************************** + ! + ! routine interp_soil_texture + ! + !> \brief Interpolate soil texture category for Noah-MP + !> \author Michael G. Duda + !> \date 31 May 2024 + !> \details + !> Interpolate soil texture category fields by using the init_atm_map_static_data + !> routine, accumulating the pixel values into each cell using + !> categorical_interp_accumulation. + !> + !> The fieldname argument specifies the specific soil texture category + !> field from the mesh pool onto which the dataset specified by geog_data_path + !> should be remapped. + !> + !> The mesh argument is an mpas_pool_type that contains the specified fieldname, + !> kdtree is an initialized mpas_kd_type tree with (xCell, yCell, zCell), and + !> supersample_fac is the supersampling factor to be applied to the source dataset. + !> + !----------------------------------------------------------------------- + subroutine interp_soil_texture(fieldname, mesh, kdtree, geog_data_path, supersample_fac) + + implicit none + + ! Input variables + character (len=*), intent(in) :: fieldname + 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 + real, dimension(:), pointer :: soilclx + type (mpas_geotile_mgr_type) :: mgr + integer, pointer :: nCells + + integer :: iCell + integer :: ierr + + ierr = mgr % init(trim(geog_data_path)) + if (ierr /= 0) then + call mpas_log_write('Error occured initalizing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + return + end if + + call mpas_pool_get_dimension(mesh, 'nCells', nCells) + call mpas_pool_get_array(mesh, trim(fieldname), soilclx) + call mpas_pool_get_config(mgr % pool, 'category_min', category_min) + call mpas_pool_get_config(mgr % pool, 'category_max', category_max) + + allocate(ncat(category_min:category_max, nCells)) + ncat(:,:) = 0 + + 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 + ! starting index of the array is 1, and dataset categories do not necessarily start + ! at 1, we need to use category_min to ensure the correct category location is chosen. + soilclx(iCell) = real(maxloc(ncat(:,iCell), dim=1) - 1 + category_min, kind=RKIND) + end do + deallocate(ncat) + + ierr = mgr % finalize() + if (ierr /= 0) then + call mpas_log_write('Error occured finalizing interpolation for '//trim(geog_data_path), & + messageType=MPAS_LOG_CRIT) + return + end if + + nullify(category_min) + nullify(category_max) + + end subroutine interp_soil_texture + !================================================================================================== subroutine init_atm_check_read_error(istatus, fname) !================================================================================================== @@ -827,6 +2225,41 @@ real (kind=RKIND) function sphere_distance(lat1, lon1, lat2, lon2, radius) end function sphere_distance +!================================================================================================== + real (kind=RKIND) function max_cell_diameter(nCells, nEdgesOnCell, verticesOnCell, latCell, lonCell, & + latVertex, lonVertex, sphere_radius) result(max_diameter) + +! Calculate upper bound on maximum diameter of any cell in block owned by this task +!================================================================================================== + implicit none + + ! Arguments + integer, intent(in) :: nCells + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: verticesOnCell + real(kind=RKIND), dimension(:), intent(in) :: latCell, lonCell + real(kind=RKIND), dimension(:), intent(in) :: latVertex, lonVertex + real(kind=RKIND), intent(in) :: sphere_radius + + ! Local variables + integer :: iCell, j + + + max_diameter = 0.0_RKIND + do iCell = 1, nCells + do j = 1, nEdgesOnCell(iCell) + max_diameter = max(max_diameter, & + sphere_distance(latCell(iCell), lonCell(iCell), & + latVertex(verticesOnCell(j,iCell)), lonVertex(verticesOnCell(j,iCell)), & + sphere_radius)) + end do + end do + + max_diameter = 2.0_RKIND * max_diameter + + end function max_cell_diameter + + !================================================================================================== end module mpas_init_atm_static !================================================================================================== 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_init_atmosphere/mpas_init_atm_thompson_aerosols.F b/src/core_init_atmosphere/mpas_init_atm_thompson_aerosols.F new file mode 100644 index 0000000000..89fc6916f1 --- /dev/null +++ b/src/core_init_atmosphere/mpas_init_atm_thompson_aerosols.F @@ -0,0 +1,867 @@ +! 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_init_atm_thompson_aerosols + use mpas_derived_types + use mpas_kind_types + use mpas_log + use mpas_dmpar + use mpas_pool_routines + + use init_atm_read_met + use init_atm_hinterp + use init_atm_llxy + use init_atm_vinterp + use mpas_atmphys_date_time + use mpas_atmphys_utilities + + implicit none + private + public:: init_atm_thompson_aerosols,init_atm_thompson_aerosols_lbc + +!mpas_init_atm_thompson_aerosols contains the subroutines needed for the interpolation of climatological +!monthly-averaged hygroscopic ("water friendly") and nonhygroscopic ("ice friendly") aerosols used in the +!Thompson parameterization of cloud microphysics with Gocart CCN and IN nucleation. +!Laura D. Fowler (laura@ucar.edu) / 2024-04-10. + + + contains + + +!================================================================================================================= + subroutine init_atm_thompson_aerosols(block,mesh,configs,diag,state) +!================================================================================================================= + +!input arguments: + type (mpas_pool_type),intent(in):: configs + type(mpas_pool_type),intent(in):: diag + +!inout arguments: + type(block_type),intent(inout),target:: block + type(mpas_pool_type),intent(inout) :: mesh + type(mpas_pool_type),intent(inout) :: state +!local variables and pointers: + character (len=StrKIND),pointer:: config_start_time + character(len=StrKIND):: filename_gocart + character(len=StrKIND):: initial_date,mess + + logical:: lexist + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_atm_thompson_aerosols:') + +!inquire if the GOCART input file exists: + lexist = .false. + filename_gocart = "QNWFA_QNIFA_SIGMA_MONTHLY.dat" + + inquire(file=filename_gocart,exist=lexist) + if(lexist) then + + call mpas_pool_get_config(configs,'config_start_time',config_start_time) + + !--- horizontal interpolation of the climatological monthly-averaged GOCART data to the MPAS mesh: + call init_hinterp_gocart(block,mesh) + + !--- interpolation of the monthly-averaged GOCART data to the initial date, and vertical interpolation to + ! the MPAS levels: + initial_date = trim(config_start_time) + call init_vinterp_gocart(initial_date,mesh,diag,state) + else + call mpas_log_write('QNWFA_QNIFA_SIGMA_MONTHLY.dat was not found in local directory:') + call mpas_log_write('nwfa and nifa are set to zero and not interpolated from climatological data.') + endif + +!call mpas_log_write('--- end subroutine init_atm_thompson_aerosols.') + call mpas_log_write(' ') + + end subroutine init_atm_thompson_aerosols + +!================================================================================================================= + subroutine init_vinterp_gocart(initial_date,mesh,diag,state) +!================================================================================================================= + +!input arguments: + character(len=StrKIND),intent(in):: initial_date + type(mpas_pool_type),intent(in):: diag + +!inout arguments: + type(mpas_pool_type),intent(inout):: mesh + type(mpas_pool_type),intent(inout):: state + +!local variables and pointers: + integer,pointer:: nCells,nGocartLevels,nVertLevels,nMonths + integer,pointer:: index_nifa,index_nwfa + integer:: iCell,k,kk,n + + real(kind=RKIND),dimension(:,:),pointer :: nifa,nwfa,pressure + real(kind=RKIND),dimension(:,:,:),pointer:: nifa_clim,nwfa_clim,pwif_clim + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND):: target_p + real(kind=RKIND),dimension(:,:),allocatable:: nifa_int,nwfa_int,pwif_int,sorted_arr + + real(kind=RKIND),dimension(:),allocatable:: dummy2 + real(kind=RKIND),dimension(:,:),allocatable:: dummy1 + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_vinterp_gocart:') + + call mpas_pool_get_dimension(mesh,'nCells' ,nCells ) + call mpas_pool_get_dimension(mesh,'nGocartLevels',nGocartLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels' ,nVertLevels ) + call mpas_pool_get_dimension(mesh,'nMonths' ,nMonths ) + + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + call mpas_pool_get_array(diag,'pressure_base',pressure) + + call mpas_pool_get_array(mesh,'nifa_gocart_clim',nifa_clim) + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',nwfa_clim) + call mpas_pool_get_array(mesh,'pwif_gocart_clim',pwif_clim) + + call mpas_pool_get_array(state,'scalars',scalars) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + if(.not.allocated(nifa_int) ) allocate(nifa_int(nGocartLevels,nCells)) + if(.not.allocated(nwfa_int) ) allocate(nwfa_int(nGocartLevels,nCells)) + if(.not.allocated(pwif_int) ) allocate(pwif_int(nGocartLevels,nCells)) + if(.not.allocated(sorted_arr)) allocate(sorted_arr(2,nGocartLevels)) + +!--- interpolation of the monthly-averaged GOCART data to the initial date, and vertical interpolation to the +! MPAS levels: + if(.not.allocated(dummy2)) allocate(dummy2(nCells)) + if(.not.allocated(dummy1)) allocate(dummy1(nMonths,nCells)) + + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = pwif_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,initial_date,dummy1,dummy2) + pwif_int(k,1:nCells) = dummy2(1:nCells) + enddo + +!--- nifa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nifa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,initial_date,dummy1,dummy2) + nifa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nifa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nifa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nifa(k,iCell) = nifa(k+1,iCell) + enddo + enddo + +!--- nwfa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nwfa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,initial_date,dummy1,dummy2) + nwfa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nwfa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nwfa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nwfa(k,iCell) = nwfa(k+1,iCell) + enddo + enddo + +!--- deallocation of local arrays: + if(allocated(dummy1) ) deallocate(dummy1 ) + if(allocated(dummy2) ) deallocate(dummy2 ) + if(allocated(nifa_int) ) deallocate(nifa_int ) + if(allocated(nwfa_int) ) deallocate(nwfa_int ) + if(allocated(pwif_int) ) deallocate(pwif_int ) + if(allocated(sorted_arr)) deallocate(sorted_arr) + +!call mpas_log_write('--- end subroutine init_vinterp_gocart:') + + end subroutine init_vinterp_gocart + +!================================================================================================================= + subroutine init_hinterp_gocart(block,mesh) +!================================================================================================================= + +!inout arguments: + type(block_type),intent(inout),target:: block + type (mpas_pool_type),intent(inout) :: mesh + +!local variables: + type(dm_info),pointer:: dminfo + type(met_data) :: field !real*4 meteorological data. + type(proj_info):: proj + + character(len=StrKIND):: filename_gocart + logical:: have_landmask + + integer,pointer:: nCells + integer:: i,j + integer:: iCell,istatus,k,masked,nmonths,nInterpPoints + integer,dimension(5):: interp_list + integer,dimension(:),pointer:: landmask + integer,dimension(:),pointer:: mask_array + + real(kind=RKIND):: fillval,maskval,msgval + real(kind=RKIND):: lat,lon,x,y + real(kind=RKIND),dimension(:),pointer :: latCell,lonCell + real(kind=RKIND),dimension(:),pointer :: latPoints,lonPoints + real(kind=RKIND),dimension(:,:,:),pointer:: nifa_clim,nwfa_clim,pwif_clim + real(kind=RKIND),dimension(:,:,:),pointer:: destField3d + + real(kind=RKIND),dimension(:,:),allocatable:: maskslab,rslab + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_hinterp_gocart:') + + dminfo => block%domain%dminfo + + filename_gocart = "QNWFA_QNIFA_SIGMA_MONTHLY.dat" + + call mpas_pool_get_dimension(mesh,'nCells',nCells) + + call mpas_pool_get_array(mesh,'landmask',landmask) + call mpas_pool_get_array(mesh,'latCell' ,latCell ) + call mpas_pool_get_array(mesh,'lonCell' ,lonCell ) + + call mpas_pool_get_array(mesh,'nifa_gocart_clim',nifa_clim) + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',nwfa_clim) + call mpas_pool_get_array(mesh,'pwif_gocart_clim',pwif_clim) + +!open intermediate file: + istatus = 0 + call read_met_init(trim(filename_gocart),.true.,'not needed',istatus) + if(istatus /= 0) then + call mpas_log_write('********************************************************************************') + call mpas_log_write('Error opening gocart file '//trim(filename_gocart)) + call mpas_log_write('********************************************************************************') + call mpas_dmpar_abort(dminfo) + else + call mpas_log_write('Processing file '//trim(filename_gocart)) + end if + +!scan through all fields in the file, looking for the LANDSEA field: + have_landmask = .false. + call read_next_met_field(field,istatus) + do while (istatus == 0) + if(index(field % field, 'LANDSEA') /= 0) then + have_landmask = .true. + if(.not.allocated(maskslab)) allocate(maskslab(-2:field%nx+3,field%ny)) + + maskslab(1:field%nx,1:field%ny) = field%slab(1:field%nx,1:field%ny) + maskslab(0 ,1:field%ny) = field%slab(field%nx ,1:field%ny) + maskslab(-1,1:field%ny) = field%slab(field%nx-1,1:field%ny) + maskslab(-2,1:field%ny) = field%slab(field%nx-2,1:field%ny) + maskslab(field%nx+1,1:field%ny) = field%slab(1,1:field%ny) + maskslab(field%nx+2,1:field%ny) = field%slab(2,1:field%ny) + maskslab(field%nx+3,1:field%ny) = field%slab(3,1:field%ny) +! call mpas_log_write('minval, maxval of LANDSEA = $r $r',realArgs=(/minval(maskslab),maxval(maskslab)/)) + end if + deallocate(field%slab) + call read_next_met_field(field,istatus) + end do + call read_met_close() + + if(.not. have_landmask) then + call mpas_log_write('********************************************************************************') + call mpas_log_write('Landsea mask not available from the surface file') + call mpas_log_write('********************************************************************************') + end if + + +!read gocart data: + istatus = 0 + call read_met_init(trim(filename_gocart),.true.,'not needed',istatus) + if(istatus /= 0) then + call mpas_log_write('********************************************************************************') + call mpas_log_write('Error opening gocart file '// trim(filename_gocart)) + call mpas_log_write('********************************************************************************') + call mpas_dmpar_abort(dminfo) + endif + call read_next_met_field(field, istatus) + +!horizontally interpolate GOCART data: + do while(istatus == 0) + + interp_list(1) = FOUR_POINT + interp_list(2) = W_AVERAGE4 + interp_list(3) = W_AVERAGE16 + interp_list(4) = SEARCH + interp_list(5) = 0 + + maskval = -1.0 + masked = -1 + fillval = 0.0 + msgval = 0.0 + + mask_array => landmask + + if(index(field % field, 'QNIFA_JAN') /= 0 .or. & + index(field % field, 'QNIFA_FEB') /= 0 .or. & + index(field % field, 'QNIFA_MAR') /= 0 .or. & + index(field % field, 'QNIFA_APR') /= 0 .or. & + index(field % field, 'QNIFA_MAY') /= 0 .or. & + index(field % field, 'QNIFA_JUN') /= 0 .or. & + index(field % field, 'QNIFA_JUL') /= 0 .or. & + index(field % field, 'QNIFA_AUG') /= 0 .or. & + index(field % field, 'QNIFA_SEP') /= 0 .or. & + index(field % field, 'QNIFA_OCT') /= 0 .or. & + index(field % field, 'QNIFA_NOV') /= 0 .or. & + index(field % field, 'QNIFA_DEC') /= 0 .or. & + index(field % field, 'QNWFA_JAN') /= 0 .or. & + index(field % field, 'QNWFA_FEB') /= 0 .or. & + index(field % field, 'QNWFA_MAR') /= 0 .or. & + index(field % field, 'QNWFA_APR') /= 0 .or. & + index(field % field, 'QNWFA_MAY') /= 0 .or. & + index(field % field, 'QNWFA_JUN') /= 0 .or. & + index(field % field, 'QNWFA_JUL') /= 0 .or. & + index(field % field, 'QNWFA_AUG') /= 0 .or. & + index(field % field, 'QNWFA_SEP') /= 0 .or. & + index(field % field, 'QNWFA_OCT') /= 0 .or. & + index(field % field, 'QNWFA_NOV') /= 0 .or. & + index(field % field, 'QNWFA_DEC') /= 0 .or. & + index(field % field, 'P_WIF_JAN') /= 0 .or. & + index(field % field, 'P_WIF_FEB') /= 0 .or. & + index(field % field, 'P_WIF_MAR') /= 0 .or. & + index(field % field, 'P_WIF_APR') /= 0 .or. & + index(field % field, 'P_WIF_MAY') /= 0 .or. & + index(field % field, 'P_WIF_JUN') /= 0 .or. & + index(field % field, 'P_WIF_JUL') /= 0 .or. & + index(field % field, 'P_WIF_AUG') /= 0 .or. & + index(field % field, 'P_WIF_SEP') /= 0 .or. & + index(field % field, 'P_WIF_OCT') /= 0 .or. & + index(field % field, 'P_WIF_NOV') /= 0 .or. & + index(field % field, 'P_WIF_DEC') /= 0) then + + ! + !set up projection: + ! + call map_init(proj) + + if(field%iproj == PROJ_LATLON) then + call map_set(PROJ_LATLON,proj, & + latinc = real(field%deltalat,RKIND), & + loninc = real(field%deltalon,RKIND), & + knowni = 1.0_RKIND, & + knownj = 1.0_RKIND, & + lat1 = real(field%startlat,RKIND), & + lon1 = real(field%startlon,RKIND)) + elseif(field%iproj == PROJ_GAUSS) then + call map_set(PROJ_GAUSS,proj, & + nlat = nint(field%deltalat), & + loninc = 360.0_RKIND / real(field%nx,RKIND), & + lat1 = real(field%startlat,RKIND), & + lon1 = real(field%startlon,RKIND)) + endif + + ! + !horizontally interpolate field at level k: + ! + if(index(field%field,'QNIFA_JAN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_JAN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 1 + elseif(index(field%field,'QNIFA_FEB') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_FEB at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 2 + elseif(index(field%field,'QNIFA_MAR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_MAR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 3 + elseif(index(field%field,'QNIFA_APR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_APR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 4 + elseif(index(field%field,'QNIFA_MAY') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_MAY at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 5 + elseif(index(field%field,'QNIFA_JUN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_JUN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 6 + elseif(index(field%field,'QNIFA_JUL') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_JUL at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 7 + elseif(index(field%field,'QNIFA_AUG') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_AUG at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 8 + elseif(index(field%field,'QNIFA_SEP') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_SEP at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 9 + elseif(index(field%field,'QNIFA_OCT') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_OCT at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 10 + elseif(index(field%field,'QNIFA_NOV') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_NOV at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 11 + elseif(index(field%field,'QNIFA_DEC') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNIFA_DEC at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nifa_gocart_clim',destField3d) + nmonths = 12 + elseif(index(field%field,'QNWFA_JAN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_JAN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 1 + elseif(index(field%field,'QNWFA_FEB') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_FEB at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 2 + elseif(index(field%field,'QNWFA_MAR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_MAR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 3 + elseif(index(field%field,'QNWFA_APR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_APR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 4 + elseif(index(field%field,'QNWFA_MAY') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_MAY at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 5 + elseif(index(field%field,'QNWFA_JUN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_JUN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 6 + elseif(index(field%field,'QNWFA_JUL') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_JUL at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 7 + elseif(index(field%field,'QNWFA_AUG') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_AUG at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 8 + elseif(index(field%field,'QNWFA_SEP') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_SEP at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 9 + elseif(index(field%field,'QNWFA_OCT') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_OCT at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 10 + elseif(index(field%field,'QNWFA_NOV') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_NOV at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 11 + elseif(index(field%field,'QNWFA_DEC') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating QNWFA_DEC at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',destField3d) + nmonths = 12 + elseif(index(field%field,'P_WIF_JAN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_JAN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 1 + elseif(index(field%field,'P_WIF_FEB') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_FEB at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 2 + elseif(index(field%field,'P_WIF_MAR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_MAR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 3 + elseif(index(field%field,'P_WIF_APR') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_APR at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 4 + elseif(index(field%field,'P_WIF_MAY') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_MAY at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 5 + elseif(index(field%field,'P_WIF_JUN') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_JUN at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 6 + elseif(index(field%field,'P_WIF_JUL') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_JUL at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 7 + elseif(index(field%field,'P_WIF_AUG') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_AUG at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 8 + elseif(index(field%field,'P_WIF_SEP') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_SEP at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 9 + elseif(index(field%field,'P_WIF_OCT') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_OCT at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 10 + elseif(index(field%field,'P_WIF_NOV') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_NOV at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 11 + elseif(index(field%field,'P_WIF_DEC') /= 0) then + k = field%xlvl + call mpas_log_write('Interpolating P_WIF_DEC at $i',intArgs=(/k/)) + nInterpPoints = nCells + latPoints => latCell + lonPoints => lonCell + call mpas_pool_get_array(mesh,'pwif_gocart_clim',destField3d) + nmonths = 12 + endif + + allocate(rslab(-2:field%nx+3,field%ny)) + rslab(1:field%nx,1:field%ny) = field%slab(1:field%nx,1:field%ny) + rslab(0,1:field%ny) = field%slab(field%nx ,1:field%ny) + rslab(-1,1:field%ny) = field%slab(field%nx-1,1:field%ny) + rslab(-2,1:field%ny) = field%slab(field%nx-2,1:field%ny) + rslab(field%nx+1,1:field%ny) = field%slab(1,1:field%ny) + rslab(field%nx+2,1:field%ny) = field%slab(2,1:field%ny) + rslab(field%nx+3,1:field%ny) = field%slab(3,1:field%ny) + + do iCell = 1, nInterpPoints + if(mask_array(iCell) /= masked) then + lat = latPoints(iCell)*DEG_PER_RAD + lon = lonPoints(iCell)*DEG_PER_RAD + call latlon_to_ij(proj,lat,lon,x,y) + if(x < 0.5) then + lon = lon + 360.0 + call latlon_to_ij(proj,lat,lon,x,y) + elseif(x > real(field%nx,kind=RKIND)+ 0.5) then + lon = lon - 360.0 + call latlon_to_ij(proj,lat,lon,x,y) + endif + + if(maskval /= -1.0) then + destField3d(nmonths,k,iCell) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1,msgval, & + interp_list,1,maskval=maskval,mask_array=maskslab) + else + destField3d(nmonths,k,iCell) = interp_sequence(x,y,1,rslab,-2,field%nx+3,1,field%ny,1,1,msgval, & + interp_list,1) + endif + else + destField3d(nmonths,k,iCell) = fillval + endif + enddo + deallocate(rslab) + + endif + deallocate(field%slab) + call read_next_met_field(field,istatus) + + enddo + + call read_met_close() + +!call mpas_log_write('--- end subroutine init_hinterp_gocart:') + + end subroutine init_hinterp_gocart + +!================================================================================================================= + subroutine init_atm_thompson_aerosols_lbc(timestamp,timestart,block,mesh,diag,state,lbc_state) +!================================================================================================================= + +!input arguments: + character(len=StrKIND),intent(in):: timestart,timestamp + type(mpas_pool_type),intent(in):: diag + type(mpas_pool_type),intent(in):: state + +!inout arguments: + type(block_type),intent(inout),target:: block + type(mpas_pool_type),intent(inout):: mesh + type(mpas_pool_type),intent(inout):: lbc_state + +!local variables and pointers: + logical:: lexist + character(len=StrKIND):: filename_gocart + + integer,pointer:: nCells,nGocartLevels,nVertLevels,nMonths + integer,pointer:: index_nifa,index_nwfa + integer:: iCell,k,kk,n + + real(kind=RKIND),dimension(:,:),pointer :: nifa,nwfa,pressure + real(kind=RKIND),dimension(:,:,:),pointer:: nifa_clim,nwfa_clim,pwif_clim + real(kind=RKIND),dimension(:,:,:),pointer:: scalars + + real(kind=RKIND):: target_p + real(kind=RKIND),dimension(:,:),allocatable:: nifa_int,nwfa_int,pwif_int,sorted_arr + + real(kind=RKIND),dimension(:),allocatable:: dummy2 + real(kind=RKIND),dimension(:,:),allocatable:: dummy1 + +!----------------------------------------------------------------------------------------------------------------- +!call mpas_log_write('--- enter subroutine init_lbc_gocart at time: ' //trim(timestamp)) + +!inquire if the GOCART input file exists: + lexist = .false. + filename_gocart = "QNWFA_QNIFA_SIGMA_MONTHLY.dat" + inquire(file=filename_gocart,exist=lexist) + if(.not. lexist) return + + +!horizontally interpolate GOCART input when computing when the initial conditions at start time: + if(timestamp == timestart) then + call init_hinterp_gocart(block,mesh) + endif + + + call mpas_pool_get_dimension(mesh,'nCells' ,nCells ) + call mpas_pool_get_dimension(mesh,'nGocartLevels',nGocartLevels) + call mpas_pool_get_dimension(mesh,'nVertLevels' ,nVertLevels ) + call mpas_pool_get_dimension(mesh,'nMonths' ,nMonths ) + + call mpas_pool_get_dimension(state,'index_nifa',index_nifa) + call mpas_pool_get_dimension(state,'index_nwfa',index_nwfa) + + call mpas_pool_get_array(diag,'pressure_base',pressure) + + call mpas_pool_get_array(mesh,'nifa_gocart_clim',nifa_clim) + call mpas_pool_get_array(mesh,'nwfa_gocart_clim',nwfa_clim) + call mpas_pool_get_array(mesh,'pwif_gocart_clim',pwif_clim) + + call mpas_pool_get_array(lbc_state,'lbc_scalars',scalars) + nifa => scalars(index_nifa,:,:) + nwfa => scalars(index_nwfa,:,:) + + if(.not.allocated(nifa_int) ) allocate(nifa_int(nGocartLevels,nCells)) + if(.not.allocated(nwfa_int) ) allocate(nwfa_int(nGocartLevels,nCells)) + if(.not.allocated(pwif_int) ) allocate(pwif_int(nGocartLevels,nCells)) + if(.not.allocated(sorted_arr)) allocate(sorted_arr(2,nGocartLevels)) + + nifa(:,:) = 0._RKIND + nwfa(:,:) = 0._RKIND + +!--- interpolation of the monthly-averaged GOCART data to the initial date, and vertical interpolation to the +! MPAS levels: + if(.not.allocated(dummy2)) allocate(dummy2(nCells)) + if(.not.allocated(dummy1)) allocate(dummy1(nMonths,nCells)) + + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = pwif_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,timestamp,dummy1,dummy2) + pwif_int(k,1:nCells) = dummy2(1:nCells) + enddo + +!--- nifa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nifa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,timestamp,dummy1,dummy2) + nifa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nifa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nifa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nifa(k,iCell) = nifa(k+1,iCell) + enddo + enddo + +!--- nwfa: + do k = 1, nGocartLevels + dummy2(1:nCells) = 0._RKIND + dummy1(1:nMonths,1:nCells) = nwfa_clim(1:nMonths,k,1:nCells) + call monthly_interp_to_date(nCells,timestamp,dummy1,dummy2) + nwfa_int(k,1:nCells) = dummy2(1:nCells) + enddo + do iCell = 1, nCells + sorted_arr(1,1:nGocartLevels) = 0._RKIND + sorted_arr(2,1:nGocartLevels) = 0._RKIND + do k = 1, nGocartLevels + kk = nGocartLevels + 1 -k + sorted_arr(1,kk) = pwif_int(k,iCell) + sorted_arr(2,kk) = nwfa_int(k,iCell) + enddo + do k = nVertLevels, 1, -1 + target_p = pressure(k,iCell) + nwfa(k,iCell) = vertical_interp(target_p,nGocartLevels-1, & + sorted_arr(:,1:nGocartLevels-1),order=1,extrap=0) + if(target_p >= pwif_int(1,iCell) .and. k < nVertLevels) nwfa(k,iCell) = nwfa(k+1,iCell) + enddo + enddo + +!--- deallocation of local arrays: + if(allocated(dummy1) ) deallocate(dummy1 ) + if(allocated(dummy2) ) deallocate(dummy2 ) + if(allocated(nifa_int) ) deallocate(nifa_int ) + if(allocated(nwfa_int) ) deallocate(nwfa_int ) + if(allocated(pwif_int) ) deallocate(pwif_int ) + if(allocated(sorted_arr)) deallocate(sorted_arr) + +!call mpas_log_write('--- end subroutine init_lbc_gocart:') + + end subroutine init_atm_thompson_aerosols_lbc + +!================================================================================================================= + end module mpas_init_atm_thompson_aerosols +!================================================================================================================= diff --git a/src/core_init_atmosphere/mpas_kd_tree.F b/src/core_init_atmosphere/mpas_kd_tree.F new file mode 100644 index 0000000000..e1b39dc621 --- /dev/null +++ b/src/core_init_atmosphere/mpas_kd_tree.F @@ -0,0 +1,474 @@ +module mpas_kd_tree + + !*********************************************************************** + ! + ! module mpas_kd_tree + ! + !> \brief MPAS KD-Tree module + !> \author Miles A. Curry + !> \date 01/28/20 + !> A KD-Tree implementation to create and search perfectly balanced + !> KD-Trees. + !> + !> Use `mpas_kd_type` dervied type to construct points for mpas_kd_construct: + !> + !> real (kind=RKIND), dimension(:,:), allocatable :: array + !> type (mpas_kd_type), pointer :: tree => null() + !> type (mpas_kd_type), dimension(:), pointer :: points => null() + !> + !> allocate(array(k,n)) ! K dims and n points + !> allocate(points(n)) + !> array(:,:) = (/.../) ! Fill array with values + !> + !> do i = 1, n + !> allocate(points(i) % point(k)) ! Allocate point with k dimensions + !> points(i) % point(:) = array(:,i) + !> points(i) % id = i ! Or a value of your choice + !> enddo + !> + !> tree => mpas_kd_construct(points, k) + !> + !> call mpas_kd_free(tree) + !> deallocate(points) + !> deallocate(array) + !> + ! + !----------------------------------------------------------------------- + use mpas_kind_types, only : RKIND + + implicit none + + private + + public :: mpas_kd_type + + ! Public Subroutines + public :: mpas_kd_construct + public :: mpas_kd_search + public :: mpas_kd_free + + type mpas_kd_type + type (mpas_kd_type), pointer :: left => null() + type (mpas_kd_type), pointer :: right => null() + + integer :: split_dim + real (kind=RKIND), dimension(:), pointer :: point => null() + + integer :: id + end type mpas_kd_type + + contains + + !*********************************************************************** + ! + ! recursive routine mpas_kd_construct_internal + ! + !> \brief Create a KD-Tree from a set of k-Dimensional points + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Private, recursive function to construct a KD-Tree from an array + !> of mpas_kd_type, points, and return the root of the tree. + !> + !> ndims should be the dimensioned of each individual point found + !> in points and npoints should be the number of points. dim represents + !> the current split dimensioned and is used internally. Upon calling + !> this function, dim should always be set to 0. + ! + !----------------------------------------------------------------------- + recursive function mpas_kd_construct_internal(points, ndims, npoints, dim) result(tree) + + implicit none + + ! Input Variables + type (mpas_kd_type), dimension(:), target :: points + integer, intent(in) :: ndims + integer, value :: npoints + integer, value :: dim + + ! Return Value + type (mpas_kd_type), pointer :: tree + + ! Local Variables + integer :: median + + if (npoints < 1) then + tree => null() + return + endif + + ! Sort the points at the split dimension + dim = mod(dim, ndims) + 1 + call quickSort(points, dim, 1, npoints, ndims) + + median = (1 + npoints) / 2 + + points(median) % split_dim = dim + tree => points(median) + + ! Build the right and left sub-trees but do not include the median + ! point (the root of the current tree) + if (npoints /= 1) then + points(median) % left => mpas_kd_construct_internal(points(1:median-1), ndims, median - 1, points(median) % split_dim) + points(median) % right => mpas_kd_construct_internal(points(median+1:npoints), ndims, npoints - median, & + points(median) % split_dim) + endif + + end function mpas_kd_construct_internal + + + !*********************************************************************** + ! + ! routine mpas_kd_construct + ! + !> \brief Construct a balanced KD-Tree + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Create and return a perfectly balanced KD-Tree from an array of + !> mpas_kd_type, points. The point member of every element of the points + !> array should be allocated and set to the points desired to be in the + !> KD-Tree and ndims should be the dimensions of the points. + !> + !> Upon error, the returned tree will be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_kd_construct(points, ndims) result(tree) + + implicit none + + ! Input Varaibles + type (mpas_kd_type), dimension(:) :: points + integer, intent(in) :: ndims + + ! Return Value + type (mpas_kd_type), pointer :: tree + + ! Local Varaibles + integer :: npoints + + npoints = size(points) + + if (npoints < 1) then + tree => null() + return + endif + + tree => mpas_kd_construct_internal(points(:), ndims, npoints, 0) + + end function mpas_kd_construct + + !*********************************************************************** + ! + ! routine break_tie + ! + !> \brief Break a tie for two n-dim points + !> \author Miles A. Curry + !> \date 07/07/20 + !> \details + !> Compare 1..n dimensions of p1 and p2 and return -1 if p1(i) is less than + !> p2(i) and return 1 if p1(i) is greater than p2(i). If p1(i) and p2(i) are + !> equal, then the same comparison will be done on p1(i+1) and p2(i+1) until + !> p1(n) and p2(n). If p1(:) and p2(:) are equal across all n, then 0 will + !> be returned. + ! + !----------------------------------------------------------------------- + function break_tie(p1, p2) result(tie) + + implicit none + + ! Input Variables + type (mpas_kd_type), intent(in) :: p1 + type (mpas_kd_type), intent(in) :: p2 + integer :: tie + + integer :: i + + tie = 0 + do i = 1, size(p1 % point(:)) + if (p1 % point(i) < p2 % point(i)) then + tie = -1 + return + else if (p1 % point(i) > p2 % point(i)) then + tie = 1 + return + endif + enddo + + end function break_tie + + + !*********************************************************************** + ! + ! recursive routine mpas_kd_search_internal + ! + !> \brief Recursively search the KD-Tree for query + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Private, recursive function to search kdtree for query. Upon succes + !> res will point to the nearest neighbor to query and distance will hold + !> the squared distance between query and res. + !> + !> Distance is calculated and compared as squared distance to increase + !> efficiency. + ! + !----------------------------------------------------------------------- + recursive subroutine mpas_kd_search_internal(kdtree, query, res, distance) + + implicit none + + ! Input Variables + type (mpas_kd_type), pointer, intent(in) :: kdtree + real (kind=RKIND), dimension(:), intent(in) :: query + type (mpas_kd_type), pointer, intent(inout) :: res + real (kind=RKIND), intent(inout) :: distance + + ! Local Values + real (kind=RKIND) :: current_distance + + current_distance = sum((kdtree % point(:) - query(:))**2) + if (current_distance < distance) then + distance = current_distance + res => kdtree + else if (current_distance == distance) then + ! + ! Consistently break a tie if a query is equidistant from two points + ! + if (associated(res)) then + if (break_tie(res, kdtree) == 1) then + res => kdtree + endif + endif + endif + + ! + ! To find the nearest neighbor, first serach the tree in a similar manner + ! as a single dimensioned BST, by comparing points on the current split + ! dimension. + ! + ! If the distance between the current node and the query is less then the + ! minimum distance found within the subtree we just searched, then the nearest + ! neighbor might be in the opposite subtree, so search it. + ! + + if (query(kdtree % split_dim) > kdtree % point(kdtree % split_dim)) then + if (associated(kdtree % right)) then ! Search right + call mpas_kd_search_internal(kdtree % right, query, res, distance) + endif + if ((kdtree % point(kdtree % split_dim) - query(kdtree % split_dim))**2 <= distance .and. associated(kdtree % left)) then + call mpas_kd_search_internal(kdtree % left, query, res, distance) ! Check the other subtree + endif + else if (query(kdtree % split_dim) < kdtree % point(kdtree % split_dim)) then + if (associated(kdtree % left)) then ! Search left + call mpas_kd_search_internal(kdtree % left, query, res, distance) + endif + if ((kdtree % point(kdtree % split_dim) - query(kdtree % split_dim))**2 <= distance .and. associated(kdtree % right)) then + call mpas_kd_search_internal(kdtree % right, query, res, distance) ! Check the other subtree + endif + else ! Nearest point could be in either left or right subtree, so search both + if (associated(kdtree % right)) then + call mpas_kd_search_internal(kdtree % right, query, res, distance) + endif + if (associated(kdtree % left)) then + call mpas_kd_search_internal(kdtree % left, query, res, distance) + endif + endif + + end subroutine mpas_kd_search_internal + + !*********************************************************************** + ! + ! routine mpas_kd_search + ! + !> \brief Find the nearest point in a KD-Tree to a query + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Search kdtree and returned the nearest point to query into the + !> res argument, or an unassociated res pointer in case no point in the + !> tree is within a specified maximum distance from any point in the tree. + !> + !> If present, the optional distance argument will contain the squared + !> distance between query and res in the case that res is associated. + !> + !> The optional input argument max_distance, if provided, specifies an + !> upper bound on the distance from the query point for points in the tree + !> to be considered. (Note: the max_distance is more like the maximum + !> squared distance due to implementation details of the kd-tree.) This + !> parameter can be useful, for example, if some query points are known + !> to be far from any point in the tree and in such cases it is desirable + !> to return no closest point. + !> + !> If the dimension of query does not match the dimensions of points + !> within kdtree, then res will be returned as unassociated. Likewise, + !> if kdtree is empty/unassociated, res will be returned as unassociated. + ! + !----------------------------------------------------------------------- + subroutine mpas_kd_search(kdtree, query, res, distance, max_distance) + + implicit none + type (mpas_kd_type), pointer, intent(in) :: kdtree + real (kind=RKIND), dimension(:), intent(in) :: query + type (mpas_kd_type), pointer, intent(inout) :: res + real (kind=RKIND), intent(inout), optional :: distance + real (kind=RKIND), intent(in), optional :: max_distance + + real (kind=RKIND) :: dis + + nullify(res) + + if (.not. associated(kdtree)) then + return + end if + + if (size(kdtree % point) /= size(query)) then + return + endif + + if (present(max_distance)) then + dis = max_distance + else + dis = huge(dis) + endif + + call mpas_kd_search_internal(kdtree, query, res, dis) + + if (present(distance) .and. associated(res)) then + distance = dis + endif + + end subroutine mpas_kd_search + + !*********************************************************************** + ! + ! routine mpas_kd_free + ! + !> \brief Free all nodes within a tree. + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Deallocate and nullify all point nodes of kdtree and nullify the + !> left and right pointers. + !> + !> After calling this function, the array of mpas_kd_type that was used + !> to construct kdtree will still be allocated and will need to be + !> deallocated separate from this routine. + ! + !----------------------------------------------------------------------- + recursive subroutine mpas_kd_free(kdtree) + + implicit none + type (mpas_kd_type), pointer :: kdtree + + if (.not. associated(kdtree)) then + return + endif + + if (associated(kdtree % left)) then + call mpas_kd_free(kdtree % left) + endif + + if (associated(kdtree % right)) then + call mpas_kd_free(kdtree % right) + endif + + deallocate(kdtree % point) + nullify(kdtree % left) + nullify(kdtree % right) + nullify(kdtree) + + end subroutine mpas_kd_free + + + !*********************************************************************** + ! + ! routine mpas_kd_quicksort + ! + !> \brief Sort an array along a dimension + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Sort points starting from arrayStart, to arrayEnd along the given dimension + !> `dim`. If two points are swapped, the entire K-Coordinate point are swapped. + ! + !----------------------------------------------------------------------- + recursive subroutine quickSort(array, dim, arrayStart, arrayEnd, ndims) + + implicit none + + ! Input Variables + type (mpas_kd_type), dimension(:) :: array + integer, intent(in), value :: dim + integer, intent(in), value :: arrayStart, arrayEnd + integer, intent(in) :: ndims + + ! Local Variables + type (mpas_kd_type) :: temp + real (kind=RKIND), dimension(ndims) :: pivot_value + + integer :: l, r, pivot, s + + if ((arrayEnd - arrayStart) < 1) then + return + endif + + ! Create the left, right, and start pointers + l = arrayStart + r = arrayEnd - 1 + s = l + + pivot = (l+r)/2 + pivot_value = array(pivot) % point + + ! Move the pivot to the far right + temp = array(pivot) + array(pivot) = array(arrayEnd) + array(arrayEnd) = temp + + do while (.true.) + ! Advance the left pointer until it is a value less then our pivot_value(dim) + do while (.true.) + if (array(l) % point(dim) < pivot_value(dim)) then + l = l + 1 + else + exit + endif + enddo + + ! Advance the right pointer until it is a value more then our pivot_value(dim) + do while (.true.) + if (r <= 0) then + exit + endif + + if(array(r) % point(dim) >= pivot_value(dim)) then + r = r - 1 + else + exit + endif + enddo + + if (l >= r) then + exit + else ! Swap elements about the pivot + temp = array(l) + array(l) = array(r) + array(r) = temp + endif + enddo + + ! Move the pivot to l ended up + temp = array(l) + array(l) = array(arrayEnd) + array(arrayEnd) = temp + + ! Quick Sort on the lower partition + call quickSort(array(:), dim, s, l-1, ndims) + + ! Quick sort on the upper partition + call quickSort(array(:), dim, l+1, arrayEnd, ndims) + + end subroutine quicksort + +end module mpas_kd_tree diff --git a/src/core_init_atmosphere/mpas_parse_geoindex.F b/src/core_init_atmosphere/mpas_parse_geoindex.F new file mode 100644 index 0000000000..753ed4ee80 --- /dev/null +++ b/src/core_init_atmosphere/mpas_parse_geoindex.F @@ -0,0 +1,256 @@ +module mpas_parse_geoindex + + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_ERR, MPAS_LOG_WARN + use mpas_pool_routines + + implicit none + + private + + public :: mpas_parse_index + + contains + + !*********************************************************************** + ! + ! subroutine mpas_parse_index + ! + !> \brief Parse a geogrid's index file and put the results into an MPAS pool + !> \author Miles A. Curry + !> \date 02/20/2020 + !> \details + !> Parse an index file of a static data set into an MPAS pool, allocating + !> each keyword=value pair into the pool with the pool member key being + !> keyword, and the value being value. + !> + !> This function can parse index files with one keyword=value pair + !> per line; a "#" at the start of a line, which will cause the line to be + !> ignored; or an empty line containing only a newline/return character, which + !> will also be ignored. Spaces or tabs before, between or after the + !> keyword=value tokens are > ignored. + !> + !> If a line contains anything but the above valid syntaxes, a syntax + !> error will raised and -1 will be returned. + !> + !> Case is ignored. + !> + !> The definitions of a keyword, which can found in section 3-53 + !> of the WRF-AWR User's Guide, will determine the corresponding type + !> of that keyword. A keyword that has been assigned the wrong type + !> will raise a type error and -1 will be returned. + !> + !> Keywords that are not handled explicitly by this function will produce + !> a warning that the keyword is unrecognized. + ! + !----------------------------------------------------------------------- + function mpas_parse_index(path, geo_pool) result(ierr) + + use mpas_io_units + + implicit none + ! Input Variables + character (len=*), intent(in) :: path + type (mpas_pool_type), intent(inout) :: geo_pool + integer :: ierr + + ! Local Variables + character (len=StrKIND) :: line, lhs, rhs + character (len=StrKIND) :: read_err_msg, open_msg + integer :: geo_unit + integer :: open_stat, read_stat, line_read_stat + integer :: i, k + logical :: res + + character (len=StrKIND) :: char_t + integer :: iceiling, ifloor + integer :: int_t + real(kind=RKIND) :: real_t + + ierr = 0 + + inquire(file=trim(path), exist=res) + if ( .not. res) then + call mpas_log_write("Could not find or open the file at: "//trim(path), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + call mpas_new_unit(geo_unit) + open_stat = 0 + open(geo_unit, FILE=trim(path), action='READ', iostat=open_stat, iomsg=open_msg) + if (open_stat /= 0) then + call mpas_release_unit(geo_unit) + call mpas_log_write("Could not open 'index' file at:'"//trim(path)//"'", messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(open_msg), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + line_read_stat = 0 + read_stat = 0 + k = 1 ! Keep track of line numbers for error reporting + read(geo_unit,'(a)', iostat=line_read_stat) line + do while ( line_read_stat == 0 ) + line = lowercase(line) + + ! + ! If a blank or comment line is encountered, read the next line + ! + if (line(1:1) == '#' .or. len_trim(line) == 0) then + k = k + 1 + read(geo_unit,'(a)', iostat=line_read_stat) line + cycle + endif + + do i = 1, len(trim(line)), 1 + if (line(i:i) == '=') then + lhs = adjustl(trim(line(1:i-1))) + rhs = adjustl(trim(line(i+1:len(trim(line))))) + exit + endif + ! If i is at the end of the string, and we haven't broken out of this loop, + ! then we do not have a '=' present in this line, thus we have a syntax error + if (i == len(trim(line))) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Syntax error on line $i of index file: '"//trim(path)//"'", & + intArgs=(/k/), messageType=MPAS_LOG_ERR) + call mpas_log_write("Line $i: '"//trim(line)//"'", intArgs=(/k/), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + enddo + + ! + ! Strings + ! + if ( trim(lhs) == 'type' & + .or. trim(lhs) == 'projection' & + .or. trim(lhs) == 'units' & + .or. trim(lhs) == 'description' & + .or. trim(lhs) == 'row_order' & + .or. trim(lhs) == 'endian' & + .or. trim(lhs) == 'mminlu' ) then + + char_t = rhs + call mpas_pool_add_config(geo_pool, trim(lhs), char_t) + + ! + ! Reals + ! + else if ( trim(lhs) == 'dx' & + .or. trim(lhs) == 'dy' & + .or. trim(lhs) == 'known_x' & + .or. trim(lhs) == 'known_y' & + .or. trim(lhs) == 'known_lat' & + .or. trim(lhs) == 'known_lon' & + .or. trim(lhs) == 'scale_factor' & + .or. trim(lhs) == 'stdlon' & + .or. trim(lhs) == 'truelat1' & + .or. trim(lhs) == 'truelat2' & + .or. trim(lhs) == 'missing_value' ) then + + read(rhs, *, iostat=read_stat, iomsg=read_err_msg) real_t + call mpas_pool_add_config(geo_pool, trim(lhs), real_t) + + ! + ! Integers + ! + else if ( trim(lhs) == 'tile_x' & + .or. trim(lhs) == 'tile_y' & + .or. trim(lhs) == 'tile_z' & + .or. trim(lhs) == 'tile_z_start' & + .or. trim(lhs) == 'tile_z_end' & + .or. trim(lhs) == 'tile_bdr' & + .or. trim(lhs) == 'wordsize' & + .or. trim(lhs) == 'category_max' & + .or. trim(lhs) == 'category_min' & + .or. trim(lhs) == 'iswater' & + .or. trim(lhs) == 'islake' & + .or. trim(lhs) == 'isice' & + .or. trim(lhs) == 'isurban' & + .or. trim(lhs) == 'isoilwater' & + .or. trim(lhs) == 'filename_digits' ) then + + ! Because each compiler handles reporting type errors when transferring + ! data in a read statement a little bit differently, we will have to type check + ! integer values ourselves. + read(rhs, *, iostat=read_stat, iomsg=read_err_msg) real_t + iceiling = ceiling(real_t) + ifloor = floor(real_t) + if (iceiling /= ifloor) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Type error while reading '"//trim(path)//"'.", messageType=MPAS_LOG_ERR) + call mpas_log_write("Could not convert '"//trim(rhs)//"' to an integer on line $i: '"//trim(line)//"'", & + intArgs=(/k/), messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + int_t = int(real_t) + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + + ! + ! Booleans - Yes will be assigned 1, and no will be assigned to 0 + ! + else if (lhs == 'signed') then + if (trim(rhs) == 'yes') then + int_t = 1 + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + else if (trim(rhs) == 'no') then + int_t = 0 + call mpas_pool_add_config(geo_pool, trim(lhs), int_t) + else + read_stat = -1 + read_err_msg = "Logical was not correct type" + endif + else + call mpas_log_write("Unrecognized keyword: '"//trim(lhs)//"' on line $i of '"//trim(path)//"'", intArgs=(/k/), & + messageType=MPAS_LOG_WARN) + endif + ! Since read gives us an error string in iomsg on a type error, we + ! can handle all errors for any type in one place + if ( read_stat /= 0) then + close(geo_unit) + call mpas_release_unit(geo_unit) + call mpas_log_write("Type error on line $i of: '"//trim(path)//"'.", intArgs=(/k/), messageType=MPAS_LOG_ERR) + call mpas_log_write(trim(read_err_msg)//": '"//trim(line)//"'", messageType=MPAS_LOG_ERR) + ierr = -1 + return + endif + + k = k + 1 + read(geo_unit,'(a)', iostat=line_read_stat) line + enddo + + close(geo_unit) + call mpas_release_unit(geo_unit) + + end function mpas_parse_index + + + ! Returns a copy of 'str' in which all upper-case letters have been converted + ! to lower-case letters. + function lowercase(str) result(lowerStr) + + character(len=*), intent(in) :: str + character(len=len(str)) :: lowerStr + + integer :: i + integer, parameter :: offset = (iachar('a') - iachar('A')) + + + do i=1,len(str) + if (iachar(str(i:i)) >= iachar('A') .and. iachar(str(i:i)) <= iachar('Z')) then + lowerStr(i:i) = achar(iachar(str(i:i)) + offset) + else + lowerStr(i:i) = str(i:i) + end if + end do + + end function lowercase + + +end module mpas_parse_geoindex diff --git a/src/core_init_atmosphere/mpas_stack.F b/src/core_init_atmosphere/mpas_stack.F new file mode 100644 index 0000000000..7227295a9f --- /dev/null +++ b/src/core_init_atmosphere/mpas_stack.F @@ -0,0 +1,280 @@ +module mpas_stack + + implicit none + + private + + ! Public Subroutines and Structures + public :: mpas_stack_is_empty + public :: mpas_stack_push + public :: mpas_stack_pop + public :: mpas_stack_free + + public :: mpas_stack_type, mpas_stack_payload_type + + type mpas_stack_payload_type + end type mpas_stack_payload_type + + type mpas_stack_type + type (mpas_stack_type), pointer :: next => null() + class (mpas_stack_payload_type), pointer :: payload => null() + end type mpas_stack_type + + !*********************************************************************** + ! + ! module mpas_stack + ! + !> \brief MPAS Stack module + !> \author Miles A. Curry + !> \date 04/04/19 + !> \details + !> + !> Introduction + !> ============== + !> The MPAS stack is a simple, extensible data stack data structure for use + !> within the MPAS atmospheric model. It functions as a wrapper around a + !> polymorphic data structure to provide usage in different areas. + !> + !> + !> Creating a Stack + !> ================== + !> The stack data structure (`type (mpas_stack_type)`) is defined by a single + !> `next` pointer > and a pointer to a `type (mpas_stack_payload_type)`, which + !> is defined as a empty derived type. + !> + !> To use the stack, create a derived type that extends the `mpas_stack_payload_type` + !> type. Define your extended derived type with members that meets your application. + !> + !> For instance: + !> ``` + !> type, extends(mpas_stack_payload_type) :: my_payload_name + !> ! Define the members of your type as you wish + !> end type my_payload_name + !> + !> class (my_payload_name), pointer :: item1 => null(), item2 => null() + !> ``` + !> + !> The extended mpas_stack_payload_type will enable a user defined type to be + !> associated with a stack item. The stack stores references of a payload, thus + !> a single payload can be used in multiple push operations. + !> + !> You will then need to create a stack (or multiple stacks if you desire) as + !> the following: + !> + !> ``` + !> type (mpas_stack_type), pointer :: stack1 => null(), stack2 => null() + !> ``` + !> + !> Pushing onto a Stack + !> ==================== + !> You can push your items onto a stack as: + !> + !> ``` + !> allocate(item1) + !> stack1 => mpas_stack_push(stack1, item1) + !> allocate(item2) + !> stack1 => mpas_stack_push(stack1, item2) + !> ``` + !> + !> Popping an item off of the stack + !> ================================ + !> Popping an item off of the stack will require a bit more work than pushing. + !> Because the payload is a polymorphic class , we will need to use the select + !> case to get our type (or multiple types) back into a usable object: + !> ``` + !> ! The item to pop items into + !> class (mpas_stack_payload_type), pointer :: top + !> type (my_payload_name), pointer :: my_item + !> + !> top => mpas_stack_pop(stack1) + !> select type(top) + !> type is(my_payload_name) + !> my_item => top + !> end select + !> ``` + !> + !> Note: It is recommended to create your own `pop` function so you can reduce + !> the amount of coded needed. An example is provided at the bottom of + !> this module as the function `user_pop(..)` + ! + !----------------------------------------------------------------------- + + contains + + !*********************************************************************** + ! + ! routine mpas_stack_is_empty + ! + !> \brief Returns .true. if the stack is empty, otherwise .false. + !> \author Miles A. Curry + !> \date 01/28/20 + !> Returns .true. If the stack is empty and/or if the stack is unassociated. + ! + !----------------------------------------------------------------------- + function mpas_stack_is_empty(stack) result(is_empty) + + implicit none + type (mpas_stack_type), intent(in), pointer :: stack + logical :: is_empty + + is_empty = .true. + if (associated(stack)) then + is_empty = .false. + return + endif + + end function mpas_stack_is_empty + + !*********************************************************************** + ! + ! routine mpas_stack_push + ! + !> \brief Push an item onto stack + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> + !> Push a mpas_stack_payload_type type, onto `stack` and return the new stack. If + !> `payload` is the first item to be pushed onto the stack, then `stack` + !> should be unassociated. + ! + !----------------------------------------------------------------------- + function mpas_stack_push(stack, payload) result(new_stack) + + implicit none + + type(mpas_stack_type), intent(inout), pointer :: stack + class(mpas_stack_payload_type), intent(inout), target :: payload + + type(mpas_stack_type), pointer :: new_stack + + allocate(new_stack) + new_stack % payload => payload + new_stack % next => stack + + return + + end function mpas_stack_push + + !*********************************************************************** + ! + ! function mpas_stack_pop + ! + !> \brief Pop off the last item added from a stack + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Pop off and return the top item of the stack as a `class mpas_stack_payload_type`. + !> If the stack is empty (or unassociated), then a null `class mpas_stack_payload_type` + !> pointer will be returned. `select type` will need to be used to retrieve + !> any extended members. + ! + !----------------------------------------------------------------------- + function mpas_stack_pop(stack) result(top) + + implicit none + + type (mpas_stack_type), intent(inout), pointer :: stack + type (mpas_stack_type), pointer :: next => null() + class(mpas_stack_payload_type), pointer :: top + + if ( .not. associated(stack)) then + top => null() + return + endif + + top => stack % payload + next => stack % next + deallocate(stack) + stack => next + return + + end function mpas_stack_pop + + !*********************************************************************** + ! + ! function mpas_stack_free + ! + !> \brief Deallocate the entire stack. Optionally deallocate payloads + !> \author Miles A. Curry + !> \date 01/28/20 + !> \details + !> Deallocate the entire stack. If free_payload is set to `.true.` or if + !> absent then the payload will be deallocated. If not, then the payload will not + !> be deallocated. Upon success, the stack will be unassociated. + ! + !----------------------------------------------------------------------- + subroutine mpas_stack_free(stack, free_payload) + + implicit none + + type(mpas_stack_type), intent(inout), pointer :: stack + logical, intent(in), optional :: free_payload + logical :: fpl + + type(mpas_stack_type), pointer :: cur + + if (present(free_payload)) then + fpl = free_payload + else + fpl = .true. + endif + + cur => stack + do while(associated(stack)) + stack => stack % next + if ( fpl ) then + deallocate(cur % payload) + endif + deallocate(cur) + cur => stack + enddo + + end subroutine mpas_stack_free + + + !*********************************************************************** + ! + ! Example user-defined pop function + ! + !> \brief Pop off the last item added from a stack and return it as our + !> defined type + !> \author Miles A. Curry + !> \date 01/28/20 + ! + !----------------------------------------------------------------------- + ! function user_pop(stack) result(item) + ! + ! use mpas_stack, only : mpas_stack_type, mpas_stack_payload_type, mpas_stack_pop + ! + ! implicit none + ! + ! type(mpas_stack_type), intent(inout), pointer :: stack + ! + ! type(my_item), pointer :: item ! Our user defined mpas_stack_type + ! + ! ! We will need to use the mpas_stack_payload_type type to use mpas_stack_pop(...) + ! class(mpas_stack_payload_type), pointer :: top + ! + ! ! + ! ! Handle a pop on an empty stack if we want to here + ! ! Note the stack will return null if it is empty. + ! ! + ! if (mpas_stack_is_empty(stack)) then + ! item => null() + ! return + ! endif + ! + ! top => mpas_stack_pop(stack) + ! + ! select type(top) + ! type is(my_item) + ! item => top + ! class default + ! write(0,*) "We got an Error and we should handle it if we need to!!" + ! stop + ! end select + ! + ! end function user_pop + +end module mpas_stack diff --git a/src/core_init_atmosphere/read_geogrid.c b/src/core_init_atmosphere/read_geogrid.c index ef783e208f..ec66892bea 100644 --- a/src/core_init_atmosphere/read_geogrid.c +++ b/src/core_init_atmosphere/read_geogrid.c @@ -9,10 +9,6 @@ Sample subroutine to read an array from the geogrid binary format. - Notes: Depending on the compiler and compiler flags, the name of - the read_geogrid() routine may need to be adjusted with respect - to the number of trailing underscores when calling from Fortran. - Michael G. Duda, NCAR/MMM */ @@ -20,27 +16,41 @@ #include #include -#ifdef UNDERSCORE -#define read_geogrid read_geogrid_ -#endif -#ifdef DOUBLEUNDERSCORE -#define read_geogrid read_geogrid__ -#endif #define GEOG_BIG_ENDIAN 0 #define GEOG_LITTLE_ENDIAN 1 +/* In Fortran, use the following as an interface for read_geogrid: + + use iso_c_binding, only : c_char, c_int, c_float, c_ptr, c_loc + + interface + subroutine read_geogrid(fname, rarray, nx, ny, nz, isigned, endian, & + wordsize, status) bind(C) + use iso_c_binding, only : c_char, c_int, c_float, c_ptr + character (c_char), dimension(*), intent(in) :: fname + type (c_ptr), value :: rarray + integer (c_int), intent(in), value :: nx + integer (c_int), intent(in), value :: ny + integer (c_int), intent(in), value :: nz + integer (c_int), intent(in), value :: isigned + integer (c_int), intent(in), value :: endian + integer (c_int), intent(in), value :: wordsize + integer (c_int), intent(inout) :: status + end subroutine read_geogrid + end interface + +*/ + int read_geogrid( char * fname, /* The name of the file to read from */ - int * len, /* The length of the filename */ float * rarray, /* The array to be filled */ - int * nx, /* x-dimension of the array */ - int * ny, /* y-dimension of the array */ - int * nz, /* z-dimension of the array */ - int * isigned, /* 0=unsigned data, 1=signed data */ - int * endian, /* 0=big endian, 1=little endian */ - float * scalefactor, /* value to multiply array elements by before truncation to integers */ - int * wordsize, /* number of bytes to use for each array element */ + int nx, /* x-dimension of the array */ + int ny, /* y-dimension of the array */ + int nz, /* z-dimension of the array */ + int isigned, /* 0=unsigned data, 1=signed data */ + int endian, /* 0=big endian, 1=little endian */ + int wordsize, /* number of bytes to use for each array element */ int * status) { int i, ival, cnt, narray; @@ -48,27 +58,22 @@ int read_geogrid( int A3, B3, C3; int A4, B4, C4, D4; unsigned char * c; - char local_fname[1024]; FILE * bfile; *status = 0; - narray = (*nx) * (*ny) * (*nz); - - /* Make a null-terminated local copy of the filename */ - strncpy(local_fname,fname,*len); - local_fname[*len]='\0'; + narray = (nx) * (ny) * (nz); /* Attempt to open file for reading */ - if (!(bfile = fopen(local_fname,"rb"))) + if (!(bfile = fopen(fname,"rb"))) { *status = 1; return 1; } /* Allocate memory to hold bytes from file and read data */ - c = (unsigned char *)malloc(sizeof(unsigned char)*(*wordsize) * narray); - cnt = fread((void *)c, sizeof(unsigned char), narray*(*wordsize), bfile); + c = (unsigned char *)malloc(sizeof(unsigned char)* wordsize * narray); + cnt = fread((void *)c, sizeof(unsigned char), narray * wordsize, bfile); fclose(bfile); @@ -83,7 +88,7 @@ int read_geogrid( A, B, C, D give the offsets of the LSB through MSB (i.e., for word ABCD, A=MSB, D=LSB) in the array from the beginning of a word */ - if (*endian == GEOG_BIG_ENDIAN) { + if (endian == GEOG_BIG_ENDIAN) { A2 = 0; B2 = 1; A3 = 0; B3 = 1; C3 = 2; A4 = 0; B4 = 1; C4 = 2; D4 = 3; @@ -95,12 +100,12 @@ int read_geogrid( } /* Convert words from native byte order */ - switch(*wordsize) { + switch(wordsize) { case 1: for(i=0; i (1 << 7))) ival -= (1 << 8); + if ((isigned) && (ival > (1 << 7))) ival -= (1 << 8); rarray[i] = (float)ival; } break; @@ -109,7 +114,7 @@ int read_geogrid( for(i=0; i (1 << 15))) ival -= (1 << 16); + if ((isigned) && (ival > (1 << 15))) ival -= (1 << 16); rarray[i] = (float)ival; } break; @@ -118,7 +123,7 @@ int read_geogrid( for(i=0; i (1 << 23))) ival -= (1 << 24); + if ((isigned) * (ival > (1 << 23))) ival -= (1 << 24); rarray[i] = (float)ival; } break; @@ -127,7 +132,7 @@ int read_geogrid( for(i=0; i (1 << 31))) ival = -(~ival + 1); + if ((isigned) && (ival > (1 << 31))) ival = -(~ival + 1); rarray[i] = (float)ival; } break; @@ -135,12 +140,5 @@ int read_geogrid( free(c); - /* Scale real-valued array by scalefactor */ - if (*scalefactor != 1.0) - { - for (i=0; i Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi diff --git a/src/core_landice/Registry.xml b/src/core_landice/Registry.xml index 5a4936794d..57e34cc8fd 100644 --- a/src/core_landice/Registry.xml +++ b/src/core_landice/Registry.xml @@ -1,5 +1,5 @@ - + 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 665be262f9..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 @@ -190,15 +191,16 @@ end function li_setup_clock !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function li_setup_log(logInfo, domain) result(iErr)!{{{ + function li_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -207,7 +209,7 @@ function li_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -235,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/Makefile b/src/core_ocean/Makefile index 24ae631991..a793d09603 100644 --- a/src/core_ocean/Makefile +++ b/src/core_ocean/Makefile @@ -31,7 +31,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi diff --git a/src/core_ocean/Registry.xml b/src/core_ocean/Registry.xml index bde204347f..3c1b5dee95 100644 --- a/src/core_ocean/Registry.xml +++ b/src/core_ocean/Registry.xml @@ -1,5 +1,5 @@ - + +/* In Fortran, use the following as an interface for compute_ev_2 and + compute_ev_3: + + interface + subroutine compute_ev_2(A, wr, wi) bind(C)!{{{ + use iso_c_binding, only: c_double + real (c_double), dimension(2,2) :: A + real (c_double), dimension(2) :: wr + real (c_double), dimension(2) :: wi + end subroutine compute_ev_2!}}} + end interface + + interface + subroutine compute_ev_3(A, wr, wi) bind(C)!{{{ + use iso_c_binding, only: c_double + real (c_double), dimension(3,3) :: A + real (c_double), dimension(3) :: wr + real (c_double), dimension(3) :: wi + end subroutine compute_ev_3!}}} + end interface + + */ -#ifdef UNDERSCORE -#define compute_ev_2 compute_ev_2_ -#define compute_ev_3 compute_ev_3_ -#else -#ifdef DOUBLEUNDERSCORE -#define compute_ev_2 compute_ev_2__ -#define compute_ev_3 compute_ev_3__ -#endif -#endif +#include #ifdef SINGLE_PRECISION typedef float real; diff --git a/src/core_ocean/driver/mpas_ocn_core_interface.F b/src/core_ocean/driver/mpas_ocn_core_interface.F index 0906754b93..28609948d3 100644 --- a/src/core_ocean/driver/mpas_ocn_core_interface.F +++ b/src/core_ocean/driver/mpas_ocn_core_interface.F @@ -95,11 +95,12 @@ end subroutine ocn_setup_domain!}}} !> *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 @@ -483,15 +484,16 @@ end function ocn_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function ocn_setup_log(logInfo, domain) result(iErr)!{{{ + function ocn_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -500,7 +502,7 @@ function ocn_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -528,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 @@ -536,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_seaice/Makefile b/src/core_seaice/Makefile index f24c5e017b..798ad2a573 100644 --- a/src/core_seaice/Makefile +++ b/src/core_seaice/Makefile @@ -9,7 +9,7 @@ core_seaice: column_package shared analysis_members model_forward gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) core_input_gen: if [ ! -e default_inputs ]; then mkdir default_inputs; fi diff --git a/src/core_seaice/Registry.xml b/src/core_seaice/Registry.xml index a78da19325..53b51e0e52 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 @@ -673,15 +674,16 @@ end function seaice_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function seaice_setup_log(logInfo, domain) result(iErr)!{{{ + function seaice_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -690,7 +692,7 @@ function seaice_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -717,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 @@ -725,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_sw/Makefile b/src/core_sw/Makefile index eb19b5a296..34ccfe5bce 100644 --- a/src/core_sw/Makefile +++ b/src/core_sw/Makefile @@ -21,7 +21,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi diff --git a/src/core_sw/Registry.xml b/src/core_sw/Registry.xml index b5574a8fb5..1a1596cdf6 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 ce0b8d5fa1..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 @@ -188,15 +189,16 @@ end function sw_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function sw_setup_log(logInfo, domain) result(iErr)!{{{ + function sw_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -205,7 +207,7 @@ function sw_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -233,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 @@ -241,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_sw/mpas_sw_time_integration.F b/src/core_sw/mpas_sw_time_integration.F index 31ece470c2..39c2a73880 100644 --- a/src/core_sw/mpas_sw_time_integration.F +++ b/src/core_sw/mpas_sw_time_integration.F @@ -175,17 +175,54 @@ subroutine sw_rk4(domain, dt) block => block % next end do - + ! Fourth-order Runge-Kutta, solving dy/dt = f(t,y) is typically written as follows + ! dt is the large time step. Here f(t,y) is the right hand side, + ! called the tendencies in the code below. + ! k_1 = f(t_n , y_n) + ! k_2 = f(t_n + dt/2, y_n + dt/2 k_1) + ! k_3 = f(t_n + dt/2, y_n + dt/2 k_2) + ! k_4 = f(t_n + dt , y_n + dt k_3) + ! y_{n+1} = y_n + dt( 1/6 k_1 + 1/3 k_2 + 1/3 k_3 + 1/6 k_4 ) + + ! in index notation: + ! k_{j+1} = f(t_n + a_j dt, y_n + a_j dt k_j) + ! y_{n+1} = y_n + dt sum ( b_j k_j ) + + ! The algorithm here uses a provisional set of the state variables, yp, + ! to hold y_n + a_j dt k_j. The RK4 algorithm is then + + ! yp = y_n prep provisional + ! y_{n+1} = y_n prep new solution + ! do j = 1,4 + ! halo_exch(some diagnostics) + ! tp = t_n + a_j*dt provisional time + ! k_j = f(tp,yp) compute tendencies + ! halo_exch(k_j) update tendencies halo + ! if j<4 + ! yp = y_n + a_{j+1}*dt*k_j compute provisional for next stage + ! endif + ! compute diagnostics based on yp + ! y_{n+1} = y_{n+1} + b_j*dt*k_j accumulate final solution + ! enddo + ! compute diagnostics based on y_{n+1} + + ! Final solution weights + ! b_j = (1/6, 1/3, 1/3, 1/6) + ! and are initialized here as dt * b_j: rk_weights(1) = dt/6. rk_weights(2) = dt/3. rk_weights(3) = dt/3. rk_weights(4) = dt/6. + ! Provisional solution weights for each stage are typically written + ! a_j = (0, 1/2, 1/2, 1). + ! However, in the algorithm below we pre-compute the state for the tendency one + ! iteration early, so it is + ! a = (1/2, 1/2, 1) rk_substep_weights(1) = dt/2. rk_substep_weights(2) = dt/2. rk_substep_weights(3) = dt - rk_substep_weights(4) = 0. - + rk_substep_weights(4) = 0. ! This coefficient is not used. !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! BEGIN RK loop @@ -201,6 +238,8 @@ subroutine sw_rk4(domain, dt) end if ! --- compute tendencies + ! In RK4 notation, we are computing the right hand side f(t,y), + ! which is the same as k_j / h. block => domain % blocklist do while (associated(block)) @@ -221,6 +260,7 @@ subroutine sw_rk4(domain, dt) call mpas_dmpar_field_halo_exch(domain, 'tend_tracers') ! --- compute next substep state + ! In RK4 notation, we are computing y_n + a_j k_j. if (rk_step < 4) then block => domain % blocklist @@ -249,6 +289,13 @@ subroutine sw_rk4(domain, dt) hProvis(:,:) = hOld(:,:) + rk_substep_weights(rk_step) * hTend(:,:) do iCell = 1, nCells do k = 1, nVertLevels + ! The tracer timestep is applied to T*h, but we are only + ! solving for the tracer T here, so we divide by the + ! thickness. + ! Tp = ( h_n*T_n + a_k * dt * tend ) / hp + ! Tp*hp = h_n*T_n + a_k * dt * tend + ! Note that tracersTend has units of tracer*thickness/time, + ! and here tracersProvis has units of just tracer. tracersProvis(:,k,iCell) = ( hOld(k,iCell) * tracersOld(:,k,iCell) & + rk_substep_weights(rk_step) * tracersTend(:,k,iCell) & ) / hProvis(k,iCell) @@ -263,6 +310,10 @@ subroutine sw_rk4(domain, dt) end if !--- accumulate update (for RK4) + ! In RK4 notation, we are computing b_j k_j and adding it to an accumulating sum + ! so that we have + ! y_{n+1} = y_n + sum ( b_j k_j ) + ! after the fourth iteration. block => domain % blocklist do while (associated(block)) @@ -289,6 +340,10 @@ subroutine sw_rk4(domain, dt) hNew(:,:) = hNew(:,:) + rk_weights(rk_step) * hTend(:,:) do iCell = 1, nCells do k = 1, nVertLevels + ! Here, tracersNew is actually the thickness-weighted tracer, + ! T*h. We accumulate the final tracer sum here as T*h, and then + ! divide out the h below. Note that the tracer tendency has + ! units of tracer*thickness/time. tracersNew(:,k,iCell) = tracersNew(:,k,iCell) + rk_weights(rk_step) * tracersTend(:,k,iCell) end do end do diff --git a/src/core_test/Makefile b/src/core_test/Makefile index d784b4fcef..5518eceda0 100644 --- a/src/core_test/Makefile +++ b/src/core_test/Makefile @@ -6,7 +6,12 @@ OBJS = mpas_test_core.o \ mpas_test_core_streams.o \ mpas_test_core_field_tests.o \ mpas_test_core_timekeeping_tests.o \ - mpas_test_core_sorting.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_openacc.o all: core_test @@ -24,7 +29,7 @@ core_input_gen: gen_includes: $(CPP) $(CPPFLAGS) $(CPPINCLUDES) Registry.xml > Registry_processed.xml (if [ ! -d inc ]; then mkdir -p inc; fi) # To generate *.inc files - (cd inc; $(REG_PARSE) < ../Registry_processed.xml ) + (cd inc; $(REG_PARSE) ../Registry_processed.xml $(CPPFLAGS) ) post_build: if [ ! -e $(ROOT_DIR)/default_inputs ]; then mkdir $(ROOT_DIR)/default_inputs; fi @@ -33,7 +38,11 @@ post_build: 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_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_string_utils.o mpas_test_core_dmpar.o \ + mpas_test_core_stream_inquiry.o mpas_test_openacc.o mpas_test_core_halo_exch.o: diff --git a/src/core_test/Registry.xml b/src/core_test/Registry.xml index fbdaaebff2..9ec004120d 100644 --- a/src/core_test/Registry.xml +++ b/src/core_test/Registry.xml @@ -1,5 +1,5 @@ - + @@ -71,6 +71,19 @@ + + + + + + + @@ -171,7 +184,10 @@ + - + + + diff --git a/src/core_test/mpas_halo_testing.F b/src/core_test/mpas_halo_testing.F new file mode 100644 index 0000000000..447663ffaf --- /dev/null +++ b/src/core_test/mpas_halo_testing.F @@ -0,0 +1,286 @@ +! 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_halo_testing + + private + + public :: mpas_halo_tests + + contains + + !*********************************************************************** + ! + ! routine mpas_halo_tests + ! + !> \brief Tests functionality of the mpas_halo module + !> \author Michael Duda + !> \date 31 May 2023 + !> \details + !> This routine tests the functionality of the mpas_halo module by building + !> different halo exchange groups, exchanging halos for fields in those + !> groups, and checking the values in the halos. + !> + !> If no errors are encountered, the ierr argument is set to 0; otherwise, + !> ierr is set to a positive integer. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_tests(domain, ierr) + + use mpas_derived_types, only : domain_type, mpas_pool_type, field2DReal, field3DReal + use mpas_kind_types, only : StrKIND, RKIND + use mpas_log, only : mpas_log_write + use mpas_dmpar, only : mpas_dmpar_max_int + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_get_field, mpas_pool_get_array, & + mpas_pool_get_dimension + use mpas_field_routines, only : mpas_allocate_scratch_field, mpas_deallocate_scratch_field + use mpas_halo + + implicit none + + type (domain_type), intent(inout) :: domain + integer, intent(out) :: ierr + + integer :: j, k + real (kind=RKIND) :: diff + integer :: ierr_local, ierr_global + character(len=StrKIND) :: test_mesg + type (mpas_pool_type), pointer :: haloExchTest_pool + type (mpas_pool_type), pointer :: mesh_pool + type (field2DReal), pointer :: scratch_2d + type (field3DReal), pointer :: scratch_3d + real (kind=RKIND), dimension(:,:), pointer :: array_2d + real (kind=RKIND), dimension(:,:,:), pointer :: array_3d + integer, dimension(:), pointer :: indexToCellID + integer, pointer :: nCells, nCellsSolve + + + ierr = 0 + ierr_local = 0 + + + nullify(haloExchTest_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'haloExchTest', haloExchTest_pool) + + nullify(mesh_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh_pool) + + nullify(indexToCellID) + call mpas_pool_get_array(mesh_pool, 'indexToCellID', indexToCellID) + + nullify(nCells) + call mpas_pool_get_dimension(mesh_pool, 'nCells', nCells) + + nullify(nCellsSolve) + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + + ! + ! Initialize the mpas_halo module + ! + write(test_mesg, '(a)') ' Initializing the mpas_halo module: ' + call mpas_halo_init(domain, ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Create a group with persistent fields + ! + write(test_mesg, '(a)') ' Creating a halo group with persistent fields: ' + call mpas_halo_exch_group_create(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'persistent_group', 'cellPersistReal2D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'persistent_group', 'cellPersistReal3D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_complete(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Create a group with scratch fields + ! + write(test_mesg, '(a)') ' Creating a halo group with scratch fields: ' + call mpas_halo_exch_group_create(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'scratch_group', 'cellScratchReal3D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_add_field(domain, 'scratch_group', 'cellScratchReal2D', iErr=ierr_local) + ierr = ior(ierr, ierr_local) + + call mpas_halo_exch_group_complete(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Exchange a group with persistent fields + ! + write(test_mesg, '(a)') ' Exchanging a halo group with persistent fields: ' + + call mpas_pool_get_array(haloExchTest_pool, 'cellPersistReal2D', array_2d) + do k = 1, size(array_2d, dim=1) + array_2d(k,:) = -1.0_RKIND + array_2d(k,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + + call mpas_pool_get_array(haloExchTest_pool, 'cellPersistReal3D', array_3d) + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + array_3d(k,j,:) = -1.0_RKIND + array_3d(k,j,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + end do + + call mpas_halo_exch_group_full_halo_exch(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + diff = 0.0_RKIND + do k = 1, size(array_2d, dim=1) + diff = diff + sum(abs(array_2d(k,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + diff = diff + sum(abs(array_3d(k,j,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + end do + + if (diff > 0.0_RKIND) then + ierr_local = 1 + ierr = ior(ierr, ierr_local) + end if + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Exchange a group with scratch fields + ! + write(test_mesg, '(a)') ' Exchanging a halo group with scratch fields: ' + + call mpas_pool_get_field(haloExchTest_pool, 'cellScratchReal2D', scratch_2d) + call mpas_pool_get_field(haloExchTest_pool, 'cellScratchReal3D', scratch_3d) + + call mpas_allocate_scratch_field(scratch_2d) + call mpas_allocate_scratch_field(scratch_3d) + + call mpas_pool_get_array(haloExchTest_pool, 'cellScratchReal2D', array_2d) + do k = 1, size(array_2d, dim=1) + array_2d(k,:) = -1.0_RKIND + array_2d(k,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + + call mpas_pool_get_array(haloExchTest_pool, 'cellScratchReal3D', array_3d) + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + array_3d(k,j,:) = -1.0_RKIND + array_3d(k,j,1:nCellsSolve) = real(indexToCellID(1:nCellsSolve), kind=RKIND) + end do + end do + + call mpas_halo_exch_group_full_halo_exch(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + diff = 0.0_RKIND + do k = 1, size(array_2d, dim=1) + diff = diff + sum(abs(array_2d(k,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + + do k = 1, size(array_3d, dim=1) + do j = 1, size(array_3d, dim=2) + diff = diff + sum(abs(array_3d(k,j,1:nCells) - real(indexToCellID(1:nCells), kind=RKIND))) + end do + end do + + call mpas_deallocate_scratch_field(scratch_2d) + call mpas_deallocate_scratch_field(scratch_3d) + + if (diff > 0.0_RKIND) then + ierr_local = 1 + ierr = ior(ierr, ierr_local) + end if + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Destroy a group with persistent fields + ! + write(test_mesg, '(a)') ' Destroying a halo group with persistent fields: ' + call mpas_halo_exch_group_destroy(domain, 'persistent_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Destroy a group with scratch fields + ! + write(test_mesg, '(a)') ' Destroying a halo group with scratch fields: ' + call mpas_halo_exch_group_destroy(domain, 'scratch_group', ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + ! + ! Finalize the mpas_halo module + ! + write(test_mesg, '(a)') ' Finalizing the mpas_halo module: ' + call mpas_halo_finalize(domain, ierr_local) + ierr = ior(ierr, ierr_local) + + if (ierr_local == 0) then + test_mesg = trim(test_mesg)//' SUCCESS' + else + test_mesg = trim(test_mesg)//' FAILURE' + end if + call mpas_log_write(trim(test_mesg)) + + call mpas_dmpar_max_int(domain % dminfo, ierr, ierr_global) + ierr = ierr_global + + end subroutine mpas_halo_tests + +end module mpas_halo_testing diff --git a/src/core_test/mpas_test_core.F b/src/core_test/mpas_test_core.F index 033b4cab19..d0a826c771 100644 --- a/src/core_test/mpas_test_core.F +++ b/src/core_test/mpas_test_core.F @@ -92,7 +92,12 @@ function test_core_run(domain) result(iErr)!{{{ use mpas_geometry_utils 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 + use mpas_test_core_openacc, only : mpas_test_openacc + implicit none type (domain_type), intent(inout) :: domain @@ -119,6 +124,19 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_log_write(' * Sorting tests: FAILURE', MPAS_LOG_ERR) end if + ! + ! Test functionality of mpas_halo module + ! + call mpas_log_write('') + call mpas_log_write('Testing mpas_halo module:') + call mpas_halo_tests(domain, iErr) + if (iErr == 0) then + call mpas_log_write('* mpas_halo tests: SUCCESS') + else + call mpas_log_write('* mpas_halo tests: FAILURE', MPAS_LOG_ERR) + end if + call mpas_log_write('') + iErr = 0 call mpas_unit_test_fix_periodicity(iErr) @@ -153,6 +171,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) @@ -166,6 +212,23 @@ function test_core_run(domain) result(iErr)!{{{ call mpas_stream_mgr_write(domain % streamManager, forceWriteNow=.true.) + ! + ! Run mpas_test_openacc + ! + call mpas_log_write('') +#ifdef MPAS_OPENACC + iErr = mpas_test_openacc(domain) + if (iErr == 0) then + call mpas_log_write('All tests PASSED') + else + call mpas_log_write('$i tests FAILED', intArgs=[iErr]) + end if +#else + call mpas_log_write('MPAS_OPENACC not defined, skipping OpenACC tests') +#endif + call mpas_log_write('') + + deallocate(threadErrs) end function test_core_run!}}} 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..b098fcfc6a 100644 --- a/src/core_test/mpas_test_core_halo_exch.F +++ b/src/core_test/mpas_test_core_halo_exch.F @@ -7,6 +7,7 @@ ! !#define HALO_EXCH_DEBUG +!#define HALO_EXCH_DEBUG_VERBOSE module test_core_halo_exch @@ -51,7 +52,7 @@ subroutine test_core_halo_exch_test(domain, threadErrs, err)!{{{ call mpas_timer_start('halo exch tests') if ( threadNum == 0 ) then - call mpas_log_write(' - Performing exchange group tests') + call mpas_log_write(' - Performing group halo exchange tests') end if call test_core_halo_exch_group_test(domain, threadErrs, iErr) call mpas_threading_barrier() @@ -80,6 +81,16 @@ subroutine test_core_halo_exch_test(domain, threadErrs, err)!{{{ err = ior(err, iErr) end if + if ( threadNum == 0 ) then + call mpas_log_write(' - Performing halo exchange adjoint tests') + end if + call test_halo_adj_exch_fields(domain, threadErrs, iErr) + call mpas_threading_barrier() + if ( threadNum == 0 ) then + call mpas_log_write(' -- Return code: $i', intArgs=(/iErr/)) + err = ior(err, iErr) + end if + call mpas_timer_stop('halo exch tests') end subroutine test_core_halo_exch_test!}}} @@ -104,8 +115,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 +126,7 @@ 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 :: iErr integer :: threadNum threadNum = mpas_threading_get_thread_num() + 1 @@ -269,7 +259,8 @@ subroutine test_core_halo_exch_full_test(domain, threadErrs, err)!{{{ call mpas_threading_barrier() - call test_core_halo_exch_validate_fields(domain, threadErrs, err) + call test_core_halo_exch_validate_fields(domain, threadErrs, iErr) + err = ior(err, iErr) end subroutine test_core_halo_exch_full_test!}}} @@ -992,6 +983,131 @@ 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 +1147,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 +1194,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 - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real1D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nCells, indexToCellID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - 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 +1215,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 + threadErrs(threadNum) = computeErrors(nEdges, indexToEdgeID, 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 - - 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 +1236,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 - - if ( sum(real4D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nVertices, indexToVertexID, 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 #ifdef HALO_EXCH_DEBUG call mpas_log_write(' -- Test result: $i', intArgs=(/threadErrs(threadNum)/)) #endif @@ -1312,71 +1257,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 - - if ( sum(real3D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if - - if ( sum(real2D) /= 0.0_RKIND ) then - threadErrs(threadNum) = 1 - end if + threadErrs(threadNum) = computeErrors(nCells, indexToCellID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - 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 +1278,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 +1299,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 + threadErrs(threadNum) = computeErrors(nVertices, indexToVertexID, real5D, real4D, real3D, real2D, real1D, & + int3d, int2d, int1d) - 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 block => block % next - end do + end do call mpas_threading_barrier() @@ -1613,5 +1384,262 @@ subroutine test_core_halo_exch_validate_fields(domain, threadErrs, err)!{{{ end subroutine test_core_halo_exch_validate_fields!}}} + !*********************************************************************** + !> \brief Identify cells that are adjacent to other marked cells + !> \author Michael Duda + !> \date 24 January 2024 + !> \details + !> Given a cell mask field, cellMask, and a specified (positive) non-zero mask + !> value, sentinelValue, this routine sets the cell mask field to (sentinelValue+1) + !> for all cells that are (1) adjacent to cells with the sentinelValue mask value + !> and (2) that have an initial cellMask value of zero. + !> + !> Cell adjacency is determined by the cellsOnCell and nEdgesOnCell fields. + !> + !> This routine returns the total number of cells that were marked as being + !> adjacent to cells with the sentinelValue mask value. + !----------------------------------------------------------------------- + function mark_interior_cells(cellMask, sentinelValue, cellsOnCell, nEdgesOnCell) result(nCellsMarked) + + ! Arguments + integer, dimension(:), intent(inout) :: cellMask !< mask field + integer, intent(in) :: sentinelValue !< value in mask field for which adjacent cells are marked + integer, dimension(:,:), intent(in) :: cellsOnCell !< indices of cell neighbors for each cell + integer, dimension(:), intent(in) :: nEdgesOnCell !< number of cell neighbors for each cell + + ! Return value + integer :: nCellsMarked + + ! Local variables + integer :: iCell, j + + + nCellsMarked = 0 + + do iCell = 1, size(cellMask) + if (cellMask(iCell) == 0) then + do j = 1, nEdgesOnCell(iCell) + if (cellMask(cellsOnCell(j, iCell)) == sentinelValue) then + cellMask(iCell) = sentinelValue + 1 + nCellsMarked = nCellsMarked + 1 +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' mark_interior iCell:$i abuts:$i', & + intArgs = (/iCell, cellsOnCell(j,iCell)/)) +#endif + exit + end if + end do + end if + end do + +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' mark_interior nCellsMarked:$i sentinel:$i', & + intArgs=(/nCellsMarked, sentinelValue/)) +#endif + + end function mark_interior_cells + + !*********************************************************************** + !> \brief Identify cells in the outermost N layers of owned cells in a block + !> \author Jim Wittig, Michael Duda + !> \date 29 January 2024 + !> \details + !> This function identifies cells that are in the outermost N layers of owned + !> cells in a block, where N is the number of halo layers (nHaloLayers). The + !> function returns an array of values indicating the location of a cell. + !> In the returned array, a value of zero indicates that the cell is not in + !> the outermost N layers of owned cells, and non-zero values indicate: + !> 1. the cell is a halo cell (not owned by this block) + !> 2. the cell is a distance of 1 away from a halo cell (i.e., adjacent to a halo cell) + !> 3. the cell is a distance of 2 away from a halo cell (i.e., adjacent to a cell marked '2') + !> 4. the cell is a distance of 3 away from a halo cell (i.e., adjacent to a cell marked '3') + !> + !> The result of this routine may be used to determine which cells will be modified + !> by the adjoint of a halo exchange; for example: + !> - cells marked with a 2 will be updated from halo layer 1, + !> - cells marked with a 3 will be updated from halo layer 2, etc. + !> + !----------------------------------------------------------------------- + function findExteriorCells(nCellsSolve, nCells, cellsOnCell, edgesOnCell, nHaloLayers) & + result(exteriorCells) + + ! Arguments + integer, intent(in) :: nCellsSolve !< the number of cells in this block + integer, intent(in) :: nCells !< total number of cells (cells in this block plus halo cells) + integer, dimension(:,:), intent(in) :: cellsOnCell !< array with adjacent cells for each cell + integer, dimension(:), intent(in) :: edgesOnCell !< array with edges for each cell + integer, intent(in) :: nHaloLayers !< the number of halo layers + + ! Return value + integer, dimension(:), allocatable :: exteriorCells + + ! Local variables + integer nInterior, nEdge, nLayers + + allocate(exteriorCells(nCells)) + exteriorCells(1:nCellsSolve) = 0 !< mark all owned cells as interior + exteriorCells(nCellsSolve+1:nCells) = 1 !< mark all halo cells as edge + nInterior = 0 + nEdge = 0 +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo cellsOnCell($i x $i)', & + intArgs=(/size(cellsOnCell, dim=1), size(cellsOnCell, dim=2)/)) +#endif + + ! At this point, only halo cells are marked 1, and all owned cells are marked 0 + ! for each halo layer, mark cells adjacent to already marked cells with next highest marker + do nLayers = 1, nHaloLayers + nEdge = nEdge + mark_interior_cells(exteriorCells(1:nCells), nLayers, cellsOnCell, edgesOnCell) + end do + + nInterior = nCellsSolve - nEdge + +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo nInterior:$i nEdge:$i', intArgs=(/nInterior, nEdge/)) +#endif + + end function findExteriorCells + + !*********************************************************************** + !> \brief MPAS Test Core halo adjoint exchange + !> \author Jim Wittig + !> \date 29 January 2024 + !> \details + !> This routine applies the adjoint of a halo exchangeto a 2-d array and + !> verifies that (1) the values for cells more than a distance N away from + !> a halo cell do not change (where N is the number of halo layers), and + !> (2) cells within a distance of N from a halo cell are updated. + !> + !> This routine assumes that a halo exchange has already been applied to + !> the cellPersistReal2D field before this routine has been called. + !> + !> Upon success, a value of 0 is returned; otherwise, a non-zero status + !> code is returned. + !----------------------------------------------------------------------- + subroutine test_halo_adj_exch_fields(domain, threadErrs, err) + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, dimension(:), intent(out) :: threadErrs + integer, intent(out) :: err + + ! Local variables + type (block_type), pointer :: block + type (mpas_pool_type), pointer :: meshPool, haloExchTestPool + type (field2DReal), pointer :: real2DField + real (kind=RKIND), dimension(:, :), pointer :: real2D + real (kind=RKIND), dimension(:, :), allocatable :: real2Dorig + integer, dimension(:,:), pointer :: cellsOnCell + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:), allocatable :: exteriorCells + integer, pointer :: nCells, nCellsSolve + integer :: iCell, iEdgeOnCell, nInterior, nEdge, nHaloLayers + + err = 0 + + ! get a variable to call the adjoint halo on + block => domain % blocklist + + call mpas_pool_get_subpool(block % structs, 'haloExchTest', haloExchTestPool) + call mpas_pool_get_subpool(block % structs, 'mesh', meshPool) + call mpas_pool_get_field(haloExchTestPool, 'cellPersistReal2D', real2DField) + call mpas_pool_get_dimension(haloExchTestPool, 'nCells', nCells) + call mpas_pool_get_dimension(haloExchTestPool, 'nCellsSolve', nCellsSolve) +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' test_halo_adj_exch_fields nCellsSolve:$i nCells:$i', & + intArgs=(/nCellsSolve, nCells/)) +#endif + + ! make a copy of the data before applying the adjoint halo + call mpas_pool_get_array(haloExchTestPool, 'cellPersistReal2D', real2D) + allocate(real2Dorig(size(real2D, 2), size(real2D, 1))) + real2Dorig = real2D + + ! find cells with adjoining ghost cells + call MPAS_pool_get_array(meshPool, 'cellsOnCell', cellsOnCell) + call MPAS_pool_get_array(meshPool, 'nEdgesOnCell', nEdgesOnCell) +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo_adj_ cellsOnCell size:$ix$i', & + intArgs=(/size(cellsOnCell,2), size(cellsOnCell, 1)/)) +#endif + + nHaloLayers = size(real2DField % sendList % halos) + exteriorCells = findExteriorCells(nCellsSolve, nCells, cellsOnCell, nEdgesOnCell, nHaloLayers) + + ! run the adjoint halo, this will update owned cells + call mpas_dmpar_exch_halo_adj_field(real2DField) + + do while ( associated(block) ) + + ! get the real2D array after calling mpas_dmpar_exch_halo_adj_field + call mpas_pool_get_array(haloExchTestPool, 'cellPersistReal2D', real2D) + + ! check the adjoint halo operation populated fields correctly + err = check_adjoint_values(nCellsSolve, real2Dorig, real2D, exteriorCells) + block => block % next + end do + + end subroutine test_halo_adj_exch_fields + + !*********************************************************************** + !> \brief MPAS Test check pre and post adjoint exchange values + !> \author Jim Wittig + !> \date 29 January 2024 + !> \details + !> This routine checks the pre-adjoint halo exchange values aganst + !> post-adjoint halo exhange values. + !> Interior cell's values aren't expected to change, and border cell's values are + !> expected to change. + !> Returns 0 on success, non-0 on failure. + !----------------------------------------------------------------------- + integer function check_adjoint_values(nCellsSolve, orig, adjoint, exteriorCells) + + integer, pointer, intent(in) :: nCellsSolve !< the number of local owned cells + real (kind=RKIND), dimension(:,:), intent(in) :: orig !< values of the cells before applying the adjoint exchange + real (kind=RKIND), dimension(:,:), intent(in) :: adjoint !< values of cells after applying the adjoint exchange + integer, dimension(:), intent(in) :: exteriorCells !< array indicating a cell is interior or on the edge + + integer :: i, j, nError, nInterior, nEdge + integer :: iDim1, iDim2 + + nError = 0 + iDim1 = nCellsSolve + iDim2 = size(orig, dim=1) + nInterior = 0 + nEdge = 0 + + do i = 1, iDim1 + do j = 1, iDim2 + if (exteriorCells(i) == 0) then + if (j == 1) then + nInterior = nInterior + 1 + ! interior cells shouldn't have changed + if (orig(j, i) /= adjoint(j, i)) then + call mpas_log_write(' halo changed value for interior cell at:$i:$i orig:$r new:$r', & + intArgs=(/j,i/), realArgs=(/orig(j,i), adjoint(j,i)/)) + nError = nError + 1 + end if + end if + else + if (j == 1) then + nEdge = nEdge + 1 + ! edge cells should change + if (orig(j, i) == adjoint(j, i)) then + call mpas_log_write(' halo unchanged value for edge cell at:$i:$i $r vs $r', & + intArgs=(/i,j/), realArgs=(/orig(j, i), adjoint(j, i)/)) + nError = nError + 1 + end if + end if + end if + end do + end do +#ifdef HALO_EXCH_DEBUG_VERBOSE + call mpas_log_write(' halo nInterior:$i nEdge:$i, nError:$i', & + intArgs=(/nInterior, nEdge, nError/)) +#endif + + check_adjoint_values = nError + + end function check_adjoint_values end module test_core_halo_exch diff --git a/src/core_test/mpas_test_core_interface.F b/src/core_test/mpas_test_core_interface.F index 9779cfba1a..e600824bc4 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 @@ -222,15 +223,17 @@ end function test_setup_clock!}}} !> and allow the core to specify details of the configuration. ! !----------------------------------------------------------------------- - function test_setup_log(logInfo, domain) result(iErr)!{{{ + function test_setup_log(logInfo, domain, unitNumbers) result(iErr)!{{{ use mpas_derived_types use mpas_log + use mpas_framework, only : mpas_framework_report_settings implicit none - type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up - type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + type (mpas_log_type), intent(inout), pointer :: logInfo !< logging information object to set up + type (domain_type), intent(in), pointer :: domain !< domain object to provide info for setting up log manager + integer, dimension(2), intent(in), optional :: unitNumbers !< Fortran unit numbers to use for output and error logs integer :: iErr ! Local variables @@ -239,7 +242,7 @@ function test_setup_log(logInfo, domain) result(iErr)!{{{ iErr = 0 ! Initialize log manager - call mpas_log_init(logInfo, domain, err=local_err) + call mpas_log_init(logInfo, domain, unitNumbers=unitNumbers, err=local_err) iErr = ior(iErr, local_err) ! Set core specific options here @@ -250,6 +253,8 @@ function test_setup_log(logInfo, domain) result(iErr)!{{{ call mpas_log_open(err=local_err) iErr = ior(iErr, local_err) + call mpas_framework_report_settings(domain) + end function test_setup_log!}}} @@ -267,7 +272,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 @@ -275,6 +280,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/core_test/mpas_test_openacc.F b/src/core_test/mpas_test_openacc.F new file mode 100644 index 0000000000..c3b9e6b424 --- /dev/null +++ b/src/core_test/mpas_test_openacc.F @@ -0,0 +1,312 @@ +! 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 https://mpas-dev.github.io/license.html . +! +module mpas_test_core_openacc + + use mpas_log, only : mpas_log_write + + private + + public :: mpas_test_openacc + + contains + + !----------------------------------------------------------------------- + ! function mpas_test_openacc + ! + !> \brief Main driver for tests of OpenACC functionality in MPAS + !> \author G. Dylan Dickerson + !> \date 14 May 2024 + !> \details + !> This routine invokes tests for expected OpenACC behavior and any + !> framework routines that are specific to OpenACC. + !> + !> Return value: The total number of test that failed on any MPI rank. + ! + !----------------------------------------------------------------------- + function mpas_test_openacc(domain) result(ierr_count) + + use mpas_derived_types, only : domain_type + use mpas_kind_types, only : StrKIND + use mpas_dmpar, only : mpas_dmpar_max_int + + implicit none + + ! Arguments + type (domain_type), intent(inout) :: domain + + ! Return value + integer :: ierr_count + + ! Local variables + integer :: ierr, ierr_global + ! Use test_log_str to track what is being tested next + character(len=StrKIND) :: test_log_str + + ierr_count = 0 + + call mpas_log_write('--- Begin OpenACC tests') + + test_log_str = 'Simple CPU-GPU reproducibility test' + ierr = openacc_test_rep_arrs(domain) + if (ierr == 0) then + call mpas_log_write(' '//trim(test_log_str)//' - PASSED') + else + ierr_count = ierr_count + 1 + call mpas_log_write(' '//trim(test_log_str)//' - FAILED') + end if + + ! Make sure all threads have the max number of tests failed in + call mpas_dmpar_max_int(domain % dminfo, ierr_count, ierr_global) + ierr_count = ierr_global + + end function mpas_test_openacc + + + !----------------------------------------------------------------------- + ! routine openacc_test_rep_arrs + ! + !> \brief OpenACC test of representative of array usage + !> \author G. Dylan Dickerson + !> \date 29 May 2024 + !> \details + !> Replicates patterns from the core_atmosphere dynamics and + !> compares the results on the CPU to those on the GPU. These + !> patterns include a main routine that fetches arrays and + !> dimensions that are passed to work routines and loops + !> in the work routine that calculate some helper values before the + !> result. + !> + !> Return value: 0 (success) if the CPU and GPU results match on + !> all ranks, 1 otherwise + !----------------------------------------------------------------------- + function openacc_test_rep_arrs(domain) result(ierr) + + use mpas_derived_types, only : domain_type, mpas_pool_type + use mpas_kind_types, only : RKIND + use mpas_pool_routines, only : mpas_pool_get_subpool,mpas_pool_get_dimension, & + mpas_pool_get_array + + implicit none + + ! Arguments + type (domain_type), intent(inout) :: domain + + ! Return value + integer :: ierr + + ! Local variables + real (kind=RKIND) :: diff + + type (mpas_pool_type), pointer :: mesh_pool + integer, pointer :: nCells,nCellsSolve + integer, pointer :: nEdges,nEdgesSolve + real (kind=RKIND), dimension(:), pointer :: areaCell + integer, dimension(:), pointer :: indexToCellID + integer, dimension(:), pointer :: nEdgesOnCell + integer, dimension(:,:), pointer :: cellsOnEdge + + type (mpas_pool_type), pointer :: openaccTest_pool + real (kind=RKIND), dimension(:), pointer :: array_cpu + real (kind=RKIND), dimension(:), pointer :: array_gpu + + ierr = 0 + diff = 0.0_RKIND + + ! + ! Fetch variables + ! + nullify(mesh_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'mesh', mesh_pool) + + nullify(nCells) + call mpas_pool_get_dimension(mesh_pool, 'nCells', nCells) + + nullify(nEdges) + call mpas_pool_get_dimension(mesh_pool, 'nEdges', nEdges) + + nullify(nCellsSolve) + call mpas_pool_get_dimension(mesh_pool, 'nCellsSolve', nCellsSolve) + + nullify(nEdgesSolve) + call mpas_pool_get_dimension(mesh_pool, 'nEdgesSolve', nEdgesSolve) + + nullify(areaCell) + call mpas_pool_get_array(mesh_pool, 'areaCell', areaCell) + + nullify(indexToCellID) + call mpas_pool_get_array(mesh_pool, 'indexToCellID', indexToCellID) + + nullify(nEdgesOnCell) + call mpas_pool_get_array(mesh_pool, 'nEdgesOnCell', nEdgesOnCell) + + nullify(cellsOnEdge) + call mpas_pool_get_array(mesh_pool, 'cellsOnEdge', cellsOnEdge) + + nullify(openaccTest_pool) + call mpas_pool_get_subpool(domain % blocklist % structs, 'openaccTest', openaccTest_pool) + + nullify(array_cpu) + call mpas_pool_get_array(openaccTest_pool, 'edge_cpu', array_cpu) + + nullify(array_gpu) + call mpas_pool_get_array(openaccTest_pool, 'edge_gpu', array_gpu) + + call rep_arrs_work_cpu(nCells,nEdges,nCellsSolve,nEdgesSolve, & + areaCell,indexToCellID,nEdgesOnCell,cellsOnEdge, & + array_cpu) + + call rep_arrs_work_gpu(nCells,nEdges,nCellsSolve,nEdgesSolve, & + areaCell,indexToCellID,nEdgesOnCell,cellsOnEdge, & + array_gpu) + + diff = sum(abs(array_cpu(1:nEdges) - array_gpu(1:nEdges))) + + if (diff > 0.0_RKIND) then + ierr = ierr + 1 + end if + + end function openacc_test_rep_arrs + + + !----------------------------------------------------------------------- + ! routine rep_arrs_work_cpu + ! + !> \brief CPU work routine for OpenACC representative arrays test + !> \author G. Dylan Dickerson + !> \date 29 May 2024 + !> \details + !> Performs some array work on the CPU, based on patterns in the + !> MPAS-A dycore. + ! + !----------------------------------------------------------------------- + subroutine rep_arrs_work_cpu(nCells, nEdges, nCellsSolve, nEdgesSolve, & + areaCell, indexToCellID, nEdgesOnCell, cellsOnEdge, & + edge_arr_cpu) + + use mpas_kind_types, only : RKIND + + implicit none + + ! arguments + integer, intent(in) :: nCells, nEdges, nCellsSolve, nEdgesSolve + real (kind=RKIND), dimension(:), intent(in) :: areaCell + integer, dimension(:), intent(in) :: indexToCellID + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: cellsOnEdge + real (kind=RKIND), dimension(:), intent(inout) :: edge_arr_cpu + + ! locals + integer :: iCell, iEdge, cell1, cell2 + real (kind=RKIND), dimension(nCells) :: invArea, help_arr + + ! Compute any helpers and initialize arrs + do iCell=1,nCells + invArea(iCell) = 1.0_RKIND / areaCell(iCell) + help_arr(iCell) = 0.0_RKIND + end do + do iEdge=1,nEdges + edge_arr_cpu(iEdge) = 0.0_RKIND + end do + + ! Compute helper values (for all owned cells) + do iCell=1,nCellsSolve + help_arr(iCell) = (nEdgesOnCell(iCell)+indexToCellID(iCell)) * invArea(iCell) + end do + + ! Compute final value (for all owned edges) + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_arr_cpu(iEdge) = 0.5_RKIND * (help_arr(cell1) + help_arr(cell2)) + end do + end subroutine rep_arrs_work_cpu + + + !----------------------------------------------------------------------- + ! routine rep_arrs_work_gpu + ! + !> \brief GPU work routine for OpenACC representative arrays test + !> \author G. Dylan Dickerson + !> \date 29 May 2024 + !> \details + !> Performs some array work on the GPU, based on patterns in the + !> MPAS-A dycore. + ! + !----------------------------------------------------------------------- + subroutine rep_arrs_work_gpu(nCells, nEdges, nCellsSolve, nEdgesSolve, & + areaCell, indexToCellID, nEdgesOnCell, cellsOnEdge, & + edge_arr_gpu) + + use mpas_kind_types, only : RKIND + + implicit none + + ! arguments + integer, intent(in) :: nCells, nEdges, nCellsSolve, nEdgesSolve + real (kind=RKIND), dimension(:), intent(in) :: areaCell + integer, dimension(:), intent(in) :: indexToCellID + integer, dimension(:), intent(in) :: nEdgesOnCell + integer, dimension(:,:), intent(in) :: cellsOnEdge + real (kind=RKIND), dimension(:), intent(inout) :: edge_arr_gpu + + ! locals + integer :: iCell, iEdge, cell1, cell2 + real (kind=RKIND), dimension(nCells) :: invArea + real (kind=RKIND), dimension(nCells) :: help_arr + + !$acc enter data copyin(nCells,nEdges, & + !$acc areaCell(:), indexToCellID(:), & + !$acc nEdgesOnCell(:),cellsOnEdge(:,:)) + + !$acc enter data create(edge_arr_gpu(:),iCell,iEdge,cell1,cell2, & + !$acc invArea(:),help_arr(:)) + + ! Compute any helpers and initialize arrs + !$acc parallel default(present) async + !$acc loop gang worker vector + do iCell=1,nCells + invArea(iCell) = 1.0_RKIND / areaCell(iCell) + help_arr(iCell) = 0.0_RKIND + end do + + !$acc loop gang worker vector + do iEdge=1,nEdges + edge_arr_gpu(iEdge) = 0.0_RKIND + end do + !$acc end parallel + + ! Compute helper values (for all owned cells) + !$acc parallel default(present) wait + !$acc loop gang worker vector + do iCell=1,nCellsSolve + help_arr(iCell) = (nEdgesOnCell(iCell)+indexToCellID(iCell)) * invArea(iCell) + end do + !$acc end parallel + + ! Compute final value (for all owned edges) + !$acc parallel default(present) wait + !$acc loop gang worker vector private(cell1, cell2) + do iEdge=1,nEdgesSolve + cell1 = cellsOnEdge(1,iEdge) + cell2 = cellsOnEdge(2,iEdge) + + edge_arr_gpu(iEdge) = 0.5_RKIND * (help_arr(cell1) + help_arr(cell2)) + end do + !$acc end parallel + + !$acc exit data delete(nCells,nEdges, & + !$acc areaCell(:), indexToCellID(:), & + !$acc nEdgesOnCell(:),cellsOnEdge(:,:), & + !$acc iCell,iEdge,cell1,cell2,invArea(:),help_arr(:)) + + !$acc exit data copyout(edge_arr_gpu(:)) + + end subroutine rep_arrs_work_gpu + + +end module mpas_test_core_openacc diff --git a/src/driver/mpas.F b/src/driver/mpas.F index 339a80303a..d0370fd577 100644 --- a/src/driver/mpas.F +++ b/src/driver/mpas.F @@ -8,14 +8,18 @@ program mpas use mpas_subdriver + use mpas_derived_types, only : core_type, domain_type implicit none - call mpas_init() + type (core_type), pointer :: corelist => null() + type (domain_type), pointer :: domain => null() - call mpas_run() + call mpas_init(corelist, domain) - call mpas_finalize() + call mpas_run(domain) + + call mpas_finalize(corelist, domain) stop diff --git a/src/driver/mpas_subdriver.F b/src/driver/mpas_subdriver.F index 1952010044..ba94dcaf52 100644 --- a/src/driver/mpas_subdriver.F +++ b/src/driver/mpas_subdriver.F @@ -35,24 +35,35 @@ module mpas_subdriver use test_core_interface #endif - type (core_type), pointer :: corelist => null() - type (dm_info), pointer :: dminfo - type (domain_type), pointer :: domain_ptr contains - subroutine mpas_init() + 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 +#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 + integer :: iArg, nArgs logical :: readNamelistArg, readStreamsArg character(len=StrKIND) :: argument, namelistFile, streamsFile @@ -81,6 +92,7 @@ subroutine mpas_init() character(len=StrKIND) :: iotype logical :: streamsExists integer :: mesh_iotype + integer, save :: domainID = 0 interface subroutine xml_stream_parser(xmlname, mgr_p, comm, ierr) bind(c) @@ -107,38 +119,68 @@ end subroutine xml_stream_get_attributes readNamelistArg = .false. readStreamsArg = .false. - nArgs = command_argument_count() - iArg = 1 - do while (iArg < nArgs) - call get_command_argument(iArg, argument) - if (len_trim(argument) == 0) exit - - if ( trim(argument) == '-n' ) then - iArg = iArg + 1 + ! If provided, error check the namelistFileParam and copy it to namelistFile to override default + if (present(namelistFileParam)) then + if (len_trim(namelistFileParam) == 0) then + write (0,*) 'WARNING: mpas_init argument namelistFileParam has 0 length and will be ignored' + else if (len_trim(namelistFileParam) > len(namelistFile)) then + write(0,'(A,I5,A,I5,A)') 'CRITICAL ERROR: mpas_init argument ''namelistFileParam'' has length ',& + len_trim(namelistFileParam), ', but the maximum allowed is ', len(namelistFile), ' characters' + stop + else readNamelistArg = .true. - call get_command_argument(iArg, namelistFile) - if ( len_trim(namelistFile) == 0 ) then - write(0,*) 'ERROR: The -n argument requires a namelist file argument.' - stop - else if ( trim(namelistFile) == '-s' ) then - write(0,*) 'ERROR: The -n argument requires a namelist file argument.' - stop - end if - else if ( trim(argument) == '-s' ) then - iArg = iArg + 1 + namelistFile = trim(namelistFileParam) + end if + end if + ! If provided, error check the streamsFileParam and copy it to streamsFile to override default + if (present(streamsFileParam)) then + if (len_trim(streamsFileParam) == 0) then + write (0,*) 'WARNING: mpas_init argument streamsFileParam has 0 length and will be ignored' + else if (len_trim(streamsFileParam) > len(streamsFile)) then + write(0,'(A,I5,A,I5,A)') 'CRITICAL ERROR: mpas_init argument ''streamsFileParam'' has length ',& + len_trim(streamsFileParam), ', but the maximum allowed is ', len(streamsFile), ' characters' + stop + else readStreamsArg = .true. - call get_command_argument(iArg, streamsFile) - if ( len_trim(streamsFile) == 0 ) then - write(0,*) 'ERROR: The -s argument requires a streams file argument.' - stop - else if ( trim(streamsFile) == '-n' ) then - write(0,*) 'ERROR: The -s argument requires a streams file argument.' - stop - end if + streamsFile = trim(streamsFileParam) end if + end if - iArg = iArg + 1 - end do + ! If optional arguments weren't used, parse the command-line arguments for -n and -s + if (.not. (present(namelistFileParam) .or. present(streamsFileParam))) then + nArgs = command_argument_count() + iArg = 1 + do while (iArg < nArgs) + call get_command_argument(iArg, argument) + if (len_trim(argument) == 0) exit + + if ( trim(argument) == '-n' ) then + iArg = iArg + 1 + readNamelistArg = .true. + call get_command_argument(iArg, namelistFile) + if ( len_trim(namelistFile) == 0 ) then + write(0,*) 'ERROR: The -n argument requires a namelist file argument.' + stop + else if ( trim(namelistFile) == '-s' ) then + write(0,*) 'ERROR: The -n argument requires a namelist file argument.' + stop + end if + else if ( trim(argument) == '-s' ) then + iArg = iArg + 1 + readStreamsArg = .true. + call get_command_argument(iArg, streamsFile) + if ( len_trim(streamsFile) == 0 ) then + write(0,*) 'ERROR: The -s argument requires a streams file argument.' + stop + else if ( trim(streamsFile) == '-n' ) then + write(0,*) 'ERROR: The -s argument requires a streams file argument.' + stop + end if + end if + + iArg = iArg + 1 + end do + end if allocate(corelist) nullify(corelist % next) @@ -151,10 +193,13 @@ end subroutine xml_stream_get_attributes call mpas_allocate_domain(domain_ptr) + domain_ptr % domainID = domainID + domainID = domainID + 1 + ! ! Initialize infrastructure ! - call mpas_framework_init_phase1(domain_ptr % dminfo) + call mpas_framework_init_phase1(domain_ptr % dminfo, external_comm=external_comm) #ifdef CORE_ATMOSPHERE @@ -211,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 @@ -245,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) @@ -338,12 +401,18 @@ end subroutine xml_stream_get_attributes end subroutine mpas_init - subroutine mpas_run() + subroutine mpas_run(domain_ptr) + + use mpas_log, only: mpas_log_info implicit none + type (domain_type), intent(inout), pointer :: domain_ptr + integer :: iErr + if ( associated(domain_ptr % logInfo) ) mpas_log_info => domain_ptr % logInfo + iErr = domain_ptr % core % core_run(domain_ptr) if ( iErr /= 0 ) then call mpas_log_write('Core run failed for core '//trim(domain_ptr % core % coreName), messageType=MPAS_LOG_CRIT) @@ -352,14 +421,19 @@ subroutine mpas_run() end subroutine mpas_run - subroutine mpas_finalize() + subroutine mpas_finalize(corelist, domain_ptr) use mpas_stream_manager, only : MPAS_stream_mgr_finalize - use mpas_log, only : mpas_log_finalize + use mpas_log, only : mpas_log_finalize, mpas_log_info + use mpas_derived_types, only : MPAS_streamInfo_type implicit none + type (core_type), intent(inout), pointer :: corelist + type (domain_type), intent(inout), pointer :: domain_ptr + integer :: iErr + type (MPAS_streamInfo_type), pointer :: streamInfo ! @@ -380,9 +454,18 @@ subroutine mpas_finalize() ! 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.) + if ( associated(domain_ptr % logInfo) ) mpas_log_info => domain_ptr % logInfo + call mpas_log_finalize(iErr) if ( iErr /= 0 ) then call mpas_dmpar_global_abort('ERROR: Log finalize failed for core ' // trim(domain_ptr % core % coreName)) diff --git a/src/external/Makefile b/src/external/Makefile index 4409d9c704..9f048d3880 100644 --- a/src/external/Makefile +++ b/src/external/Makefile @@ -1,13 +1,17 @@ .SUFFIXES: .F .c .o -all: esmf_time ezxml-lib +all: esmf_time ezxml-lib smiol-lib esmf_time: - ( cd esmf_time_f90; $(MAKE) FC="$(FC) $(FFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS) -DHIDE_MPI" GEN_F90=$(GEN_F90) ) + ( cd esmf_time_f90; $(MAKE) FC="$(FC)" FFLAGS="$(FFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS) -DHIDE_MPI" GEN_F90=$(GEN_F90) ) ezxml-lib: - ( cd ezxml; $(MAKE) ) + ( cd ezxml; $(MAKE) OBJFILE="ezxml.o" ) + +smiol-lib: + $(MAKE) -C SMIOL clean: ( cd esmf_time_f90; $(MAKE) clean ) ( cd ezxml; $(MAKE) clean ) + $(MAKE) -C SMIOL clean diff --git a/src/external/SMIOL/Makefile b/src/external/SMIOL/Makefile new file mode 100644 index 0000000000..965de3e8d2 --- /dev/null +++ b/src/external/SMIOL/Makefile @@ -0,0 +1,23 @@ +override CPPINCLUDES += -DSMIOL_PNETCDF + +all: libsmiol.a libsmiolf.a + +libsmiol.a: smiol.o smiol_utils.o + ar -cr libsmiol.a smiol.o smiol_utils.o + +libsmiolf.a: smiolf.o + ar -cr libsmiolf.a smiolf.o + +clean: + $(RM) -f smiol.o smiol_utils.o libsmiol.a + $(RM) -f smiolf.o smiolf.mod libsmiolf.a + +# Cancel the built-in implicit rule for Modula-2 files (.mod) to avoid having 'make' +# try to create .o files from Fortran .mod files +%.o : %.mod + +%.o : %.F90 + $(FC) $(CPPINCLUDES) $(FFLAGS) -c $< + +%.o : %.c + $(CC) $(CPPINCLUDES) $(CFLAGS) -c $< diff --git a/src/external/SMIOL/gen_put_get.sh b/src/external/SMIOL/gen_put_get.sh new file mode 100755 index 0000000000..fb67177e03 --- /dev/null +++ b/src/external/SMIOL/gen_put_get.sh @@ -0,0 +1,409 @@ +#!/usr/bin/env sh + +filename=smiolf_put_get_var.inc + + +################################################################################ +# +# gen_put_get_var +# +# Generate a function body for a specific "SMIOLf_put/get_var" function +# Required variables: +# d = 0, 1, 2, 3 +# io = put, get +# colon_list = ":,:,:" +# dim_list = "d1,d1,d3" +# type = real32, real64 +# kind = c_float, c_double +# base_type = real, integer +# size_args = "size(buf,dim=1), size(buf,dim=2)" +# +################################################################################ +gen_put_get_var() +{ + # + # For non-scalars, build, e.g., " dimension(:,:,:)," + # + if [ $d -ge 1 ]; then + dim=" dimension(${colon_list})," + c_loc_invocation=" ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_${d}d_${type}(buf${size_args})" + else + dim="" + c_loc_invocation=" c_buf = c_loc(buf)" + fi + + # + # Character variables need special copying code... + # + if [ "${kind}" = "c_char" ]; then + + if [ "${io}" = "put" ]; then + + char_copyin=" allocate(char_buf(len(buf))) + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do" + + char_copyout=" if (associated(buf)) then + deallocate(char_buf) + end if" + + else + + char_copyin=" allocate(char_buf(len(buf))) + + ! In case buf contains more characters than will be read from the file, + ! initialize char_buf with the contents of buf to preserve un-read + ! characters during the copy of char_buf back into buf later on + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do" + + char_copyout=" if (associated(buf)) then + do i=1,len(buf) + buf(i:i) = char_buf(i) + end do + + deallocate(char_buf) + end if" + + fi + + dummy_buf_decl=" ${base_type},${dim} pointer :: buf" + char_buf_decl=" character(kind=c_char), dimension(:), allocatable, target :: char_buf" + c_loc_invocation=" c_buf = c_loc(char_buf)" + + else + char_copyin="" + char_copyout="" + dummy_buf_decl=" ${base_type}(kind=${kind}),${dim} pointer :: buf" + char_buf_decl="" + fi + + + # + # Build function documentation block + # + if [ "${io}" = "put" ]; then + + header=" !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d${d}_${type} + ! + !> \brief Writes a ${d}-d ${type} variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !-----------------------------------------------------------------------" + + else + + header=" !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d${d}_${type} + ! + !> \brief Reads a ${d}-d ${type} variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !-----------------------------------------------------------------------" + + fi + + cat >> ${filename} << EOF +$header + function SMIOLf_${io}_var_${d}d_${type}(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : ${kind}, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp +${dummy_buf_decl} + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf +${char_buf_decl} + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then +${char_copyin} +${c_loc_invocation} + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_${io}_var(c_file, c_varname, c_decomp, c_buf) + +${char_copyout} + deallocate(c_varname) + + end function SMIOLf_${io}_var_${d}d_${type} + + +EOF +} + + +################################################################################ +# +# gen_c_loc +# +# Generate a function body for a specific "c_loc_assumed_shape" function +# Required variables: +# d = 1, 2, 3 +# dim_args = , d1, d1, d3 +# dim_list = d1,d1,d3 +# type = real32, real64 +# kind = c_float, c_double +# base_type = real, integer +# +################################################################################ +gen_c_loc() +{ + # + # Build, e.g., " dimension(d1,d2,d3)," + # + dim=" dimension(${dim_list})," + + # + # Build list of dimension argument declarations + # + d_decl="integer, intent(in) :: d1" + i=2 + while [ $i -le $d ]; do + d_decl="${d_decl}, d$i" + i=$(($i+1)) + done + + # + # Build function documentation block + # + header=" !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_${d}d_${type} + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !-----------------------------------------------------------------------" + + cat >> ${filename} << EOF +${header} + function c_loc_assumed_shape_${d}d_${type}(a${dim_args}) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, ${kind} + + implicit none + + ! Arguments + ${d_decl} + ${base_type}(kind=${kind}),${dim} target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_${d}d_${type} + + +EOF +} + + +################################################################################ +# +# gen_put_get.sh +# +################################################################################ +printf "" > ${filename} + +# +# For each type, handle each dimensionality +# +for d in 0 1 2 3 4 5; do + + # + # Build list of dimension formal arguments, e.g. ", d1, d2, d3" + # + dim_args='' + i=1 + while [ $i -le $d ]; do + dim_args="${dim_args}, d$i" + i=$(($i+1)) + done + + # + # Build explicit shape list, e.g., "d1,d2,d3" + # + dim_list='' + i=1 + while [ $i -le $d ]; do + dim_list="${dim_list}d$i" + if [ $i -lt $d ]; then + dim_list="${dim_list}," + fi + i=$(($i+1)) + done + + # + # Build assumed shape list, e.g., ":,:,:" + # + colon_list='' + i=1 + while [ $i -le $d ]; do + colon_list="${colon_list}:" + if [ $i -lt $d ]; then + colon_list="${colon_list}," + fi + i=$(($i+1)) + done + + # + # Build array size actual arguments , e.g., "size(buf,dim=1), size(buf,dim=2)" + # + size_args='' + i=1 + while [ $i -le $d ]; do + + # Break long lines after three dimensions + if [ $i -eq 4 -a $d -ge 4 ]; then + size_args="${size_args}, & + size(buf,dim=$i)" + else + size_args="${size_args}, size(buf,dim=$i)" + fi + + i=$(($i+1)) + + done + + # + # Create functions for each type + # + for type in char real32 real64 int32; do + + # Only up to 0-d char interfaces + if [ "${type}" = "char" ] && [ $d -gt 0 ]; then + continue + fi + + # Only up to 4-d int32 interfaces + if [ "${type}" = "int32" ] && [ $d -gt 4 ]; then + continue + fi + + if [ "$type" = "real32" ]; then + kind="c_float" + base_type="real" + elif [ "$type" = "real64" ]; then + kind="c_double" + base_type="real" + elif [ "$type" = "int32" ]; then + kind="c_int" + base_type="integer" + elif [ "$type" = "char" ]; then + kind="c_char" + base_type="character(len=:)" + fi + + if [ $d -ge 1 ]; then + gen_c_loc + fi + + for io in put get; do + gen_put_get_var + done + + done + +done diff --git a/src/external/SMIOL/smiol.c b/src/external/SMIOL/smiol.c new file mode 100644 index 0000000000..1953e6536d --- /dev/null +++ b/src/external/SMIOL/smiol.c @@ -0,0 +1,2852 @@ +#include +#include +#include +#include +#include +#include +#include "smiol.h" +#include "smiol_utils.h" + +#ifdef SMIOL_PNETCDF +#include "pnetcdf.h" +#define PNETCDF_DEFINE_MODE 0 +#define PNETCDF_DATA_MODE 1 +#define MAX_REQS 256 +#endif + +#define START_COUNT_READ 0 +#define START_COUNT_WRITE 1 + +/* + * Local functions + */ +int build_start_count(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, + int write_or_read, size_t *element_size, + size_t *basic_type_size, int *ndims, + int *has_unlimited_dim, + size_t **start, size_t **count); + +#ifdef SMIOL_PNETCDF +int write_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + const void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ); + +int read_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ); +#endif + + +/******************************************************************************** + * + * SMIOL_fortran_init + * + * Initialize a SMIOL context from Fortran. + * + * This function is a simply a wrapper for the SMOIL_init routine that is intended + * to be called from Fortran. Accordingly, the first argument is of type MPI_Fint + * (a Fortran integer) rather than MPI_Comm. + * + ********************************************************************************/ +int SMIOL_fortran_init(MPI_Fint comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context) +{ + return SMIOL_init(MPI_Comm_f2c(comm), num_io_tasks, io_stride, context); +} + + +/******************************************************************************** + * + * SMIOL_init + * + * Initialize a SMIOL context. + * + * Initializes a SMIOL context, within which decompositions may be defined and + * files may be read and written. The input argument comm is an MPI communicator, + * and the input arguments num_io_tasks and io_stride provide the total number + * of I/O tasks and the stride between those I/O tasks within the communicator. + * + * Upon successful return the context argument points to a valid SMIOL context; + * otherwise, it is NULL and an error code other than MPI_SUCCESS is returned. + * + * Note: It is assumed that MPI_Init has been called prior to this routine, so + * that any use of the provided MPI communicator will be valid. + * + ********************************************************************************/ +int SMIOL_init(MPI_Comm comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context) +{ + MPI_Comm smiol_comm; + + /* + * Before dereferencing context below, ensure that the pointer + * the context pointer is not NULL + */ + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * We cannot check for every possible invalid argument for comm, but + * at least we can verify that the communicator is not MPI_COMM_NULL + */ + if (comm == MPI_COMM_NULL) { + /* Nullifying (*context) here may result in a memory leak, but this + * seems better than disobeying the stated behavior of returning + * a NULL context upon failure + */ + (*context) = NULL; + + return SMIOL_INVALID_ARGUMENT; + } + + *context = (struct SMIOL_context *)malloc(sizeof(struct SMIOL_context)); + if ((*context) == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Initialize context + */ + (*context)->lib_ierr = 0; + (*context)->lib_type = SMIOL_LIBRARY_UNKNOWN; + + (*context)->num_io_tasks = num_io_tasks; + (*context)->io_stride = io_stride; + + + /* + * Make a duplicate of the MPI communicator for use by SMIOL + */ + if (MPI_Comm_dup(comm, &smiol_comm) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + (*context)->fcomm = MPI_Comm_c2f(smiol_comm); + + if (MPI_Comm_size(smiol_comm, &((*context)->comm_size)) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + + if (MPI_Comm_rank(smiol_comm, &((*context)->comm_rank)) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_finalize + * + * Finalize a SMIOL context. + * + * Finalizes a SMIOL context and frees all memory in the SMIOL_context instance. + * After this routine is called, no other SMIOL routines that make reference to + * the finalized context should be called. + * + ********************************************************************************/ +int SMIOL_finalize(struct SMIOL_context **context) +{ + MPI_Comm smiol_comm; + + /* + * If the pointer to the context pointer is NULL, assume we have nothing + * to do and declare success + */ + if (context == NULL) { + return SMIOL_SUCCESS; + } + + if ((*context) == NULL) { + return SMIOL_SUCCESS; + } + + smiol_comm = MPI_Comm_f2c((*context)->fcomm); + if (MPI_Comm_free(&smiol_comm) != MPI_SUCCESS) { + free((*context)); + (*context) = NULL; + return SMIOL_MPI_ERROR; + } + + free((*context)); + (*context) = NULL; + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire + * + * Inquire about a SMIOL context. + * + * Detailed description. + * + ********************************************************************************/ +int SMIOL_inquire(void) +{ + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_open_file + * + * Opens a file within a SMIOL context. + * + * Depending on the specified file mode, creates or opens the file specified + * by filename within the provided SMIOL context. + * + * The bufsize argument specifies the size in bytes of the buffer to be attached + * to the file by I/O tasks; at present this buffer is only used by the Parallel- + * NetCDF library if the file is opened with a mode of SMIOL_FILE_CREATE or + * SMIOL_FILE_WRITE. A bufsize of 0 will force the use of the Parallel-NetCDF + * blocking write interface, while a nonzero value enables the use of the + * non-blocking, buffered interface for writing. + * + * Upon successful completion, SMIOL_SUCCESS is returned, and the file handle + * argument will point to a valid file handle and the current frame for the + * file will be set to zero. Otherwise, the file handle is NULL and an error + * code other than SMIOL_SUCCESS is returned. + * + ********************************************************************************/ +int SMIOL_open_file(struct SMIOL_context *context, const char *filename, + int mode, struct SMIOL_file **file, size_t bufsize) +{ + int io_group; + MPI_Comm io_file_comm; + MPI_Comm io_group_comm; + int ierr; + + + /* + * Before dereferencing file below, ensure that the pointer + * the file pointer is not NULL + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that context is valid + */ + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + *file = (struct SMIOL_file *)malloc(sizeof(struct SMIOL_file)); + if ((*file) == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Save pointer to context for this file + */ + (*file)->context = context; + (*file)->frame = (SMIOL_Offset) 0; + + + /* + * Determine whether a task is an I/O task or not, and compute + * the I/O group to which each task belongs + */ + (*file)->io_task = context->comm_rank % context->io_stride == 0 ? 1 : 0; + io_group = context->comm_rank / context->io_stride; + + /* + * If there are fewer than comm_size / io_stride I/O tasks, some + * tasks that were set to I/O tasks above will actually not perform + * I/O. Also, place all remainder tasks in the last I/O group + */ + if (io_group >= context->num_io_tasks) { + (*file)->io_task = 0; + io_group = context->num_io_tasks - 1; + } + + /* + * Create a communicator for communicating within a group of tasks + * associated with an I/O task + */ + ierr = MPI_Comm_split(MPI_Comm_f2c(context->fcomm), io_group, + context->comm_rank, &io_group_comm); + if (ierr != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + (*file)->io_group_comm = MPI_Comm_c2f(io_group_comm); + + + /* + * Create a communicator for collective file I/O operations among + * I/O tasks (i.e., io_task == 1) + */ + ierr = MPI_Comm_split(MPI_Comm_f2c(context->fcomm), (*file)->io_task, + context->comm_rank, &io_file_comm); + if (ierr != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + (*file)->io_file_comm = MPI_Comm_c2f(io_file_comm); + + + if (mode & SMIOL_FILE_CREATE) { +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = ncmpi_create(io_file_comm, filename, + (NC_64BIT_DATA | NC_CLOBBER), + MPI_INFO_NULL, + &((*file)->ncidp)); + } + (*file)->state = PNETCDF_DEFINE_MODE; +#endif + } else if (mode & SMIOL_FILE_WRITE) { +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = ncmpi_open(io_file_comm, filename, + NC_WRITE, MPI_INFO_NULL, + &((*file)->ncidp)); + } + (*file)->state = PNETCDF_DATA_MODE; +#endif + } else if (mode & SMIOL_FILE_READ) { +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = ncmpi_open(io_file_comm, filename, + NC_NOWRITE, MPI_INFO_NULL, + &((*file)->ncidp)); + } + (*file)->state = PNETCDF_DATA_MODE; +#endif + } else { + free((*file)); + (*file) = NULL; + MPI_Comm_free(&io_file_comm); + MPI_Comm_free(&io_group_comm); + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + free((*file)); + (*file) = NULL; + MPI_Comm_free(&io_file_comm); + MPI_Comm_free(&io_group_comm); + context->lib_type = SMIOL_LIBRARY_PNETCDF; + context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + (*file)->bufsize = 0; + (*file)->n_reqs = 0; + (*file)->reqs = NULL; + + if (mode & SMIOL_FILE_CREATE || mode & SMIOL_FILE_WRITE) { + if (bufsize > 0 && (*file)->io_task) { + (*file)->bufsize = bufsize; + ierr = ncmpi_buffer_attach((*file)->ncidp, + (MPI_Offset)bufsize); + (*file)->reqs = malloc(sizeof(int) * (size_t)MAX_REQS); + } + + if (bufsize > 0) { + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + if ((*file)->reqs != NULL) { + free((*file)->reqs); + (*file)->reqs = NULL; + } + free((*file)); + (*file) = NULL; + MPI_Comm_free(&io_file_comm); + MPI_Comm_free(&io_group_comm); + context->lib_type = SMIOL_LIBRARY_PNETCDF; + context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_close_file + * + * Closes a file within a SMIOL context. + * + * Closes the file associated with the provided file handle. Upon successful + * completion, SMIOL_SUCCESS is returned, the file will be closed, and all memory + * that is uniquely associated with the file handle will be deallocated. + * Otherwise, an error code other than SMIOL_SUCCESS will be returned. + * + ********************************************************************************/ +int SMIOL_close_file(struct SMIOL_file **file) +{ + MPI_Comm io_file_comm; + MPI_Comm io_group_comm; +#ifdef SMIOL_PNETCDF + int ierr; +#endif + + + /* + * If the pointer to the file pointer is NULL, assume we have nothing + * to do and declare success + */ + if (file == NULL) { + return SMIOL_SUCCESS; + } + + io_file_comm = MPI_Comm_f2c((*file)->io_file_comm); + io_group_comm = MPI_Comm_f2c((*file)->io_group_comm); + +#ifdef SMIOL_PNETCDF + if ((*file)->io_task) { + ierr = NC_NOERR; + if ((*file)->n_reqs > 0) { + int statuses[MAX_REQS]; + + ierr = ncmpi_wait_all((*file)->ncidp, (*file)->n_reqs, + (*file)->reqs, statuses); + (*file)->n_reqs = 0; + } + if ((*file)->reqs != NULL) { + free((*file)->reqs); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + ((*file)->context)->lib_type = SMIOL_LIBRARY_PNETCDF; + ((*file)->context)->lib_ierr = ierr; + free((*file)); + (*file) = NULL; + return SMIOL_LIBRARY_ERROR; + } + + ierr = NC_NOERR; + if ((*file)->io_task && (*file)->bufsize > 0) { + ierr = ncmpi_buffer_detach((*file)->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + ((*file)->context)->lib_type = SMIOL_LIBRARY_PNETCDF; + ((*file)->context)->lib_ierr = ierr; + free((*file)); + (*file) = NULL; + return SMIOL_LIBRARY_ERROR; + } + + if ((*file)->io_task) { + ierr = ncmpi_close((*file)->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + ((*file)->context)->lib_type = SMIOL_LIBRARY_PNETCDF; + ((*file)->context)->lib_ierr = ierr; + free((*file)); + (*file) = NULL; + return SMIOL_LIBRARY_ERROR; + } +#endif + + if (MPI_Comm_free(&io_file_comm) != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + + if (MPI_Comm_free(&io_group_comm) != MPI_SUCCESS) { + free((*file)); + (*file) = NULL; + return SMIOL_MPI_ERROR; + } + + free((*file)); + (*file) = NULL; + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_define_dim + * + * Defines a new dimension in a file. + * + * Defines a dimension with the specified name and size in the file associated + * with the file handle. If a negative value is provided for the size argument, + * the dimension will be defined as an unlimited or record dimension. + * + * Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + * code is returned. + * + ********************************************************************************/ +int SMIOL_define_dim(struct SMIOL_file *file, const char *dimname, SMIOL_Offset dimsize) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int dimidp; + int ierr; + MPI_Offset len; +#endif + + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that dimension name is valid + */ + if (dimname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * The parallel-netCDF library does not permit zero-length dimensions + */ + if (dimsize == (SMIOL_Offset)0) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Handle unlimited / record dimension specifications + */ + if (dimsize < (SMIOL_Offset)0) { + len = NC_UNLIMITED; + } + else { + len = (MPI_Offset)dimsize; + } + + /* + * If the file is in data mode, then switch it to define mode + */ + if (file->state == PNETCDF_DATA_MODE) { + if (file->io_task) { + ierr = ncmpi_redef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DEFINE_MODE; + } + + if (file->io_task) { + ierr = ncmpi_def_dim(file->ncidp, dimname, len, &dimidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire_dim + * + * Inquires about an existing dimension in a file. + * + * Inquire about the size of an existing dimension and optionally inquire if the + * given dimension is the unlimited dimension or not. If dimsize is a non-NULL + * pointer then the dimension size will be returned in dimsize. For unlimited + * dimensions, the current size of the dimension is returned; future writes of + * additional records to a file can lead to different return sizes for + * unlimited dimensions. + * + * If is_unlimited is a non-NULL pointer and if the inquired dimension is the + * unlimited dimension, is_unlimited will be set to 1; if the inquired + * dimension is not the unlimited dimension then is_unlimited will be set to 0. + * + * Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + * code is returned. + * + ********************************************************************************/ +int SMIOL_inquire_dim(struct SMIOL_file *file, const char *dimname, + SMIOL_Offset *dimsize, int *is_unlimited) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int dimidp = 0; + int ierr; + MPI_Offset len = 0; +#endif + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that dimension name is valid + */ + if (dimname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that dimension size is not NULL + */ + if (dimsize == NULL && is_unlimited == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + if (dimsize != NULL) { + (*dimsize) = (SMIOL_Offset)0; /* Default dimension size if no library provides a value */ + } + + if (is_unlimited != NULL) { + (*is_unlimited) = 0; /* Return 0 if no library provides a value */ + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + if (file->io_task) { + ierr = ncmpi_inq_dimid(file->ncidp, dimname, &dimidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + (*dimsize) = (SMIOL_Offset)(-1); /* TODO: should there be a well-defined invalid size? */ + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + /* + * Inquire about dimsize + */ + if (dimsize != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_dimlen(file->ncidp, dimidp, &len); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + (*dimsize) = (SMIOL_Offset)(-1); /* TODO: should there be a well-defined invalid size? */ + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + (*dimsize) = (SMIOL_Offset)len; +/* TO DO: what if SMIOL_Offset is different in size from MPI_LONG */ + MPI_Bcast(dimsize, 1, MPI_LONG, 0, io_group_comm); + } + + + /* + * Inquire if this dimension is the unlimited dimension + */ + if (is_unlimited != NULL) { + int unlimdimidp = 0; + if (file->io_task) { + ierr = ncmpi_inq_unlimdim(file->ncidp, &unlimdimidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + if (file->io_task) { + if (unlimdimidp == dimidp) { + (*is_unlimited) = 1; + } else { + (*is_unlimited) = 0; /* Not the unlimited dim */ + } + } + MPI_Bcast(is_unlimited, 1, MPI_INT, 0, io_group_comm); + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_define_var + * + * Defines a new variable in a file. + * + * Defines a variable with the specified name, type, and dimensions in an open + * file pointed to by the file argument. The varname and dimnames arguments + * are expected to be null-terminated strings, except if the variable has zero + * dimensions, in which case the dimnames argument may be a NULL pointer. + * + * Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + * code is returned. + * + ********************************************************************************/ +int SMIOL_define_var(struct SMIOL_file *file, const char *varname, int vartype, int ndims, const char **dimnames) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int *dimids; + int ierr; + int i; + nc_type xtype; + int varidp; +#endif + + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that variable name is valid + */ + if (varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that the variable type is valid - handled below in a library-specific way... + */ + + /* + * Check that variable dimension names are valid + */ + if (dimnames == NULL && ndims > 0) { + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + dimids = (int *)malloc(sizeof(int) * (size_t)ndims); + if (dimids == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Build a list of dimension IDs + */ + for (i=0; iio_task) { + ierr = ncmpi_inq_dimid(file->ncidp, + dimnames[i], &dimids[i]); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + free(dimids); + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } + + /* + * Translate SMIOL variable type to parallel-netcdf type + */ + switch (vartype) { + case SMIOL_REAL32: + xtype = NC_FLOAT; + break; + case SMIOL_REAL64: + xtype = NC_DOUBLE; + break; + case SMIOL_INT32: + xtype = NC_INT; + break; + case SMIOL_CHAR: + xtype = NC_CHAR; + break; + default: + free(dimids); + return SMIOL_INVALID_ARGUMENT; + } + + /* + * If the file is in data mode, then switch it to define mode + */ + if (file->state == PNETCDF_DATA_MODE) { + if (file->io_task) { + ierr = ncmpi_redef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DEFINE_MODE; + } + + /* + * Define the variable + */ + if (file->io_task) { + ierr = ncmpi_def_var(file->ncidp, varname, xtype, ndims, dimids, + &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + free(dimids); + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + free(dimids); +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire_var + * + * Inquires about an existing variable in a file. + * + * Inquires about a variable in a file, and optionally returns the type + * of the variable, the dimensionality of the variable, and the names of + * the dimensions of the variable. Which properties of the variable to return + * (type, dimensionality, or dimension names) is indicated by the status of + * the pointers for the corresponding properties: if the pointer is a non-NULL + * pointer, the property will be set upon successful completion of this routine. + * + * If the names of a variable's dimensions are requested (by providing a non-NULL + * actual argument for dimnames), the size of the dimnames array must be at least + * the number of dimensions in the variable, and each character string pointed + * to by an element of dimnames must be large enough to accommodate the corresponding + * dimension name. + * + ********************************************************************************/ +int SMIOL_inquire_var(struct SMIOL_file *file, const char *varname, int *vartype, int *ndims, char **dimnames) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int *dimids; + int varidp = 0; + int ierr; + int i; + int xtypep; + int ndimsp = 0; +#endif + + /* + * Check that file handle is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Check that variable name is valid + */ + if (varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * If all output arguments are NULL, we can return early + */ + if (vartype == NULL && ndims == NULL && dimnames == NULL) { + return SMIOL_SUCCESS; + } + + /* + * Provide default values for output arguments in case + * no library-specific below is active + */ + if (vartype != NULL) { + *vartype = SMIOL_UNKNOWN_VAR_TYPE; + } + if (ndims != NULL) { + *ndims = 0; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * Get variable ID + */ + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + /* + * If requested, inquire about variable type + */ + if (vartype != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_vartype(file->ncidp, varidp, &xtypep); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + MPI_Bcast(&xtypep, 1, MPI_INT, 0, io_group_comm); + + /* Convert parallel-netCDF variable type to SMIOL variable type */ + switch (xtypep) { + case NC_FLOAT: + *vartype = SMIOL_REAL32; + break; + case NC_DOUBLE: + *vartype = SMIOL_REAL64; + break; + case NC_INT: + *vartype = SMIOL_INT32; + break; + case NC_CHAR: + *vartype = SMIOL_CHAR; + break; + default: + *vartype = SMIOL_UNKNOWN_VAR_TYPE; + } + } + + /* + * All remaining properties will require the number of dimensions + */ + if (ndims != NULL || dimnames != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_varndims(file->ncidp, varidp, &ndimsp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + MPI_Bcast(&ndimsp, 1, MPI_INT, 0, io_group_comm); + } + + /* + * If requested, inquire about dimensionality + */ + if (ndims != NULL) { + *ndims = ndimsp; + } + + /* + * If requested, inquire about dimension names + */ + if (dimnames != NULL) { + dimids = (int *)malloc(sizeof(int) * (size_t)ndimsp); + if (dimids == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + if (file->io_task) { + ierr = ncmpi_inq_vardimid(file->ncidp, varidp, dimids); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + free(dimids); + return SMIOL_LIBRARY_ERROR; + } + + for (i = 0; i < ndimsp; i++) { + int len; + + if (dimnames[i] == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + if (file->io_task) { + ierr = ncmpi_inq_dimname(file->ncidp, dimids[i], + dimnames[i]); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + free(dimids); + return SMIOL_LIBRARY_ERROR; + } + + if (file->io_task) { + len = (int)strnlen(dimnames[i], + (size_t)NC_MAX_NAME); + len++; /* Include the terminating '\0' character */ + } + MPI_Bcast(&len, 1, MPI_INT, 0, io_group_comm); + MPI_Bcast(dimnames[i], len, MPI_CHAR, 0, io_group_comm); + } + + free(dimids); + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_put_var + * + * Writes a variable to a file. + * + * Given a pointer to a SMIOL file that was previously opened with write access + * and the name of a variable previously defined in the file with a call to + * SMIOL_define_var, this routine will write the contents of buf to the variable + * according to the decomposition described by decomp. + * + * If decomp is not NULL, the variable is assumed to be decomposed across MPI + * ranks, and all ranks with non-zero-sized partitions of the variable must + * provide a valid buffer. For decomposed variables, all MPI ranks must provide + * a non-NULL decomp, regardless of whether a rank has a non-zero-sized + * partition of the variable. + * + * If the variable is not decomposed -- that is, all ranks store identical + * values for the entire variable -- all MPI ranks must provide a NULL pointer + * for the decomp argument. As currently implemented, this routine will write + * the buffer for MPI rank 0 to the variable; however, this behavior should not + * be relied on. + * + * If the variable has been successfully written to the file, SMIOL_SUCCESS will + * be returned. Otherwise, an error code indicating the nature of the failure + * will be returned. + * + ********************************************************************************/ +int SMIOL_put_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, const void *buf) +{ + int ierr; + int ndims; + size_t element_size; + size_t basic_size; + int has_unlimited_dim; + void *out_buf = NULL; + size_t *start; + size_t *count; + + void *agg_buf = NULL; + const void *agg_buf_cnst = NULL; + + + /* + * Basic checks on arguments + */ + if (file == NULL || varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Work out the start[] and count[] arrays for writing this variable + * in parallel + */ + ierr = build_start_count(file, varname, decomp, + START_COUNT_WRITE, &element_size, &basic_size, &ndims, + &has_unlimited_dim, + &start, &count); + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + + /* + * Communicate elements of this field from MPI ranks that compute those + * elements to MPI ranks that write those elements. This only needs to + * be done for decomposed variables. + */ + if (decomp) { + out_buf = malloc(element_size * decomp->io_count); + if (out_buf == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + + if (decomp->agg_factor != 1) { + MPI_Datatype dtype; + MPI_Comm agg_comm; + + ierr = MPI_Type_contiguous((int)element_size, + MPI_UINT8_T, &dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_contiguous failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Type_commit(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_commit failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + agg_buf = malloc(element_size * decomp->n_compute_agg); + if (agg_buf == NULL && decomp->n_compute_agg > 0) { + return SMIOL_MALLOC_FAILURE; + } + + agg_comm = MPI_Comm_f2c(decomp->agg_comm); + + ierr = MPI_Gatherv((const void *)buf, + (int)decomp->n_compute, dtype, + (void *)agg_buf, + (const int *)decomp->counts, + (const int *)decomp->displs, + dtype, 0, agg_comm); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Gatherv failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Type_free(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_free failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + agg_buf_cnst = agg_buf; + } else { + agg_buf_cnst = buf; + } + + ierr = transfer_field(decomp, SMIOL_COMP_TO_IO, + element_size, agg_buf_cnst, out_buf); + if (ierr != SMIOL_SUCCESS) { + free(start); + free(count); + free(out_buf); + return ierr; + } + + if (decomp->agg_factor != 1) { + free(agg_buf); + } + } + +/* TO DO: could check that out_buf has size zero if not file->io_task */ + + /* + * Write out_buf + */ +#ifdef SMIOL_PNETCDF + { + int j; + int varidp = 0; + const void *buf_p; + MPI_Offset *mpi_start; + MPI_Offset *mpi_count; + MPI_Comm io_group_comm; + MPI_Comm io_file_comm; + + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + io_file_comm = MPI_Comm_f2c(file->io_file_comm); + + if (file->state == PNETCDF_DEFINE_MODE) { + if (file->io_task) { + ierr = ncmpi_enddef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(out_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DATA_MODE; + } + + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(out_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + + if (decomp) { + buf_p = out_buf; + } else { + buf_p = buf; + } + + mpi_start = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_start == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + + mpi_count = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_count == NULL) { + free(start); + free(count); + free(mpi_start); + + return SMIOL_MALLOC_FAILURE; + } + + for (j = 0; j < ndims; j++) { + mpi_start[j] = (MPI_Offset)start[j]; + mpi_count[j] = (MPI_Offset)count[j]; + } + + if (file->io_task) { + ierr = write_chunk_pnetcdf(file, + varidp, + ndims, + has_unlimited_dim, + basic_size, + io_file_comm, + buf_p, + mpi_start, + mpi_count + ); + } + + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + + free(mpi_start); + free(mpi_count); + + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(out_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + } +#endif + + /* + * Free up memory before returning + */ + if (decomp) { + free(out_buf); + } + + free(start); + free(count); + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_get_var + * + * Reads a variable from a file. + * + * Given a pointer to a SMIOL file and the name of a variable previously defined + * in the file, this routine will read the contents of the variable into buf + * according to the decomposition described by decomp. + * + * If decomp is not NULL, the variable is assumed to be decomposed across MPI + * ranks, and all ranks with non-zero-sized partitions of the variable must + * provide a valid buffer. For decomposed variables, all MPI ranks must provide + * a non-NULL decomp, regardless of whether a rank has a non-zero-sized + * partition of the variable. + * + * If the variable is not decomposed -- that is, all ranks load identical + * values for the entire variable -- all MPI ranks must provide a NULL pointer + * for the decomp argument. + * + * If the variable has been successfully read from the file, SMIOL_SUCCESS will + * be returned. Otherwise, an error code indicating the nature of the failure + * will be returned. + * + ********************************************************************************/ +int SMIOL_get_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, void *buf) +{ + int ierr; + int ndims; + size_t element_size; + size_t basic_size; + int has_unlimited_dim; + void *in_buf = NULL; + size_t *start; + size_t *count; + + void *agg_buf = NULL; + + MPI_Comm io_group_comm; + MPI_Comm io_file_comm; + + + /* + * Basic checks on arguments + */ + if (file == NULL || varname == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + io_file_comm = MPI_Comm_f2c(file->io_file_comm); + + /* + * Work out the start[] and count[] arrays for reading this variable + * in parallel + */ + ierr = build_start_count(file, varname, decomp, + START_COUNT_READ, &element_size, &basic_size, &ndims, + &has_unlimited_dim, + &start, &count); + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + + /* + * If this variable is decomposed, allocate a buffer into which + * the variable will be read using the I/O decomposition; later, + * elements this buffer will be transferred to MPI ranks that compute + * on those elements + */ + if (decomp) { + in_buf = malloc(element_size * decomp->io_count); + if (in_buf == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + +#ifndef SMIOL_PNETCDF + /* + * If no file library provides values for the memory pointed to + * by in_buf, the transfer_field call later will transfer + * garbage to the output buffer; to avoid returning + * non-deterministic values to the caller in this case, + * initialize in_buf. + */ + memset(in_buf, 0, element_size * decomp->io_count); + +#endif + } + +/* MGD TO DO: could verify that if not file->io_task, then size of in_buf is zero */ + + /* + * Read in_buf + */ +#ifdef SMIOL_PNETCDF + { + int j; + int varidp = 0; + void *buf_p; + MPI_Offset *mpi_start; + MPI_Offset *mpi_count; + + if (file->state == PNETCDF_DEFINE_MODE) { + if (file->io_task) { + ierr = ncmpi_enddef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(in_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DATA_MODE; + } + + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(in_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + + if (decomp) { + buf_p = in_buf; + } else { + buf_p = buf; + } + + mpi_start = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_start == NULL) { + free(start); + free(count); + + return SMIOL_MALLOC_FAILURE; + } + + mpi_count = malloc(sizeof(MPI_Offset) * (size_t)ndims); + if (mpi_count == NULL) { + free(start); + free(count); + free(mpi_start); + + return SMIOL_MALLOC_FAILURE; + } + + for (j = 0; j < ndims; j++) { + mpi_start[j] = (MPI_Offset)start[j]; + mpi_count[j] = (MPI_Offset)count[j]; + } + + ierr = NC_NOERR; + if (file->io_task) { + /* + * Finish and flush any pending writes to this file + * before reading back a variable + */ + if (file->n_reqs > 0) { + int statuses[MAX_REQS]; + + ierr = ncmpi_wait_all(file->ncidp, file->n_reqs, + file->reqs, statuses); + file->n_reqs = 0; + + if (ierr == NC_NOERR) { + ierr = ncmpi_sync(file->ncidp); + } + } + if (ierr == NC_NOERR) { + ierr = read_chunk_pnetcdf(file, + varidp, + ndims, + has_unlimited_dim, + basic_size, + io_file_comm, + buf_p, + mpi_start, + mpi_count + ); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + + free(mpi_start); + free(mpi_count); + + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + + if (decomp) { + free(in_buf); + } + free(start); + free(count); + + return SMIOL_LIBRARY_ERROR; + } + } +#endif + + /* + * Free start/count arrays + */ + free(start); + free(count); + + /* + * Communicate elements of this field from MPI ranks that read those + * elements to MPI ranks that compute those elements. This only needs to + * be done for decomposed variables. + */ + if (decomp) { + if (decomp->agg_factor != 1) { + agg_buf = malloc(element_size * decomp->n_compute_agg); + if (agg_buf == NULL && decomp->n_compute_agg > 0) { + return SMIOL_MALLOC_FAILURE; + } + } else { + agg_buf = buf; + } + + ierr = transfer_field(decomp, SMIOL_IO_TO_COMP, + element_size, in_buf, agg_buf); + + if (decomp->agg_factor != 1) { + MPI_Datatype dtype = MPI_DATATYPE_NULL; + MPI_Comm agg_comm; + + ierr = MPI_Type_contiguous((int)element_size, + MPI_UINT8_T, &dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_contiguous failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Type_commit(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_commit failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + agg_comm = MPI_Comm_f2c(decomp->agg_comm); + + ierr = MPI_Scatterv((const void *)agg_buf, + (const int*)decomp->counts, + (const int *)decomp->displs, + dtype, (void *)buf, + (int)decomp->n_compute, + dtype, 0, agg_comm); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Scatterv failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + + free(agg_buf); + + ierr = MPI_Type_free(&dtype); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "MPI_Type_free failed with code %i\n", ierr); + return SMIOL_MPI_ERROR; + } + } + + free(in_buf); + + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + } else { + /* + * For non-decomposed variables, broadcast from I/O tasks + * to other tasks in each I/O group + */ + MPI_Bcast(buf, (int)element_size, MPI_CHAR, 0, io_group_comm); + } + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_define_att + * + * Defines a new attribute in a file. + * + * Defines a new attribute for a variable if varname is not NULL, + * or a global attribute otherwise. The type of the attribute must be one + * of SMIOL_REAL32, SMIOL_REAL64, SMIOL_INT32, or SMIOL_CHAR. + * + * If the attribute has been successfully defined for the variable or file, + * SMIOL_SUCCESS is returned. + * + ********************************************************************************/ +int SMIOL_define_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int att_type, const void *att) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int ierr; + int varidp = 0; + nc_type xtype; +#endif + + /* + * Check validity of arguments + */ + if (file == NULL || att_name == NULL || att == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Checks for valid attribute type are handled in library-specific + * code, below + */ + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * If varname was provided, get the variable ID; else, the attribute + * is a global attribute not associated with a specific variable + */ + if (varname != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } else { + varidp = NC_GLOBAL; + } + + /* + * Translate SMIOL variable type to parallel-netcdf type + */ + switch (att_type) { + case SMIOL_REAL32: + xtype = NC_FLOAT; + break; + case SMIOL_REAL64: + xtype = NC_DOUBLE; + break; + case SMIOL_INT32: + xtype = NC_INT; + break; + case SMIOL_CHAR: + xtype = NC_CHAR; + break; + default: + return SMIOL_INVALID_ARGUMENT; + } + + /* + * If the file is in data mode, then switch it to define mode + */ + if (file->state == PNETCDF_DATA_MODE) { + if (file->io_task) { + ierr = ncmpi_redef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DEFINE_MODE; + } + + /* + * Add the attribute to the file + */ + if (file->io_task) { + if (att_type == SMIOL_CHAR) { + ierr = ncmpi_put_att(file->ncidp, varidp, att_name, + xtype, (MPI_Offset)strlen(att), + (const char *)att); + } else { + ierr = ncmpi_put_att(file->ncidp, varidp, att_name, + xtype, (MPI_Offset)1, + (const char *)att); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_inquire_att + * + * Inquires about an attribute in a file. + * + * Inquires about a variable attribute if varname is not NULL, or a global + * attribute otherwise. + * + * If the requested attribute is found, SMIOL_SUCCESS is returned and the memory + * pointed to by the att argument will contain the attribute value. + * + * For character string attributes, no bytes beyond the length of the attribute + * in the file will be modified in the att argument, and no '\0' character will + * be added. Therefore, calling code may benefit from initializing character + * strings before calling this routine. + * + * If SMIOL was not compiled with support for any file library, the att_type + * output argument will always be set to SMIOL_UNKNOWN_VAR_TYPE, and the att_len + * output argument will always be set to -1; the value of the att output + * argument will be unchanged. + * + ********************************************************************************/ +int SMIOL_inquire_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int *att_type, + SMIOL_Offset *att_len, void *att) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int ierr; + int varidp = 0; + nc_type xtypep = 0; + MPI_Offset lenp = 0; +#endif + + /* + * Check validity of arguments + */ + if (file == NULL || att_name == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Set output arguments in case no library sets them later + */ + if (att_len != NULL) { + *att_len = (SMIOL_Offset)-1; + } + + if (att_type != NULL) { + *att_type = SMIOL_UNKNOWN_VAR_TYPE; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * If varname was provided, get the variable ID; else, the inquiry is + * is for a global attribute not associated with a specific variable + */ + if (varname != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_varid(file->ncidp, varname, &varidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + } else { + varidp = NC_GLOBAL; + } + + /* + * Inquire about attribute type and length + */ + if (att != NULL || att_type != NULL || att_len != NULL) { + if (file->io_task) { + ierr = ncmpi_inq_att(file->ncidp, varidp, att_name, + &xtypep, &lenp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + MPI_Bcast(&lenp, sizeof(MPI_Offset), MPI_BYTE, 0, + io_group_comm); + MPI_Bcast(&xtypep, sizeof(nc_type), MPI_BYTE, 0, + io_group_comm); + + if (att_type != NULL) { + /* Convert parallel-netCDF type to SMIOL type */ + switch (xtypep) { + case NC_FLOAT: + *att_type = SMIOL_REAL32; + break; + case NC_DOUBLE: + *att_type = SMIOL_REAL64; + break; + case NC_INT: + *att_type = SMIOL_INT32; + break; + case NC_CHAR: + *att_type = SMIOL_CHAR; + break; + default: + *att_type = SMIOL_UNKNOWN_VAR_TYPE; + } + } + + if (att_len != NULL) { + *att_len = lenp; + } + } + + + /* + * Inquire about attribute value if requested + */ + if (att != NULL) { + if (file->io_task) { + ierr = ncmpi_get_att(file->ncidp, varidp, att_name, + att); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + + switch (xtypep) { + case NC_FLOAT: + ierr = MPI_Bcast(att, 1, MPI_FLOAT, 0, io_group_comm); + break; + case NC_DOUBLE: + ierr = MPI_Bcast(att, 1, MPI_DOUBLE, 0, io_group_comm); + break; + case NC_INT: + ierr = MPI_Bcast(att, 1, MPI_INT, 0, io_group_comm); + break; + case NC_CHAR: + ierr = MPI_Bcast(att, (int)lenp, MPI_CHAR, 0, + io_group_comm); + break; + } + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_sync_file + * + * Forces all in-memory data to be flushed to disk. + * + * Upon success, all in-memory data for the file associatd with the file + * handle will be flushed to the file system and SMIOL_SUCCESS will be + * returned; otherwise, an error code is returned. + * + ********************************************************************************/ +int SMIOL_sync_file(struct SMIOL_file *file) +{ +#ifdef SMIOL_PNETCDF + MPI_Comm io_group_comm; + int ierr; +#endif + + /* + * Check that file is valid + */ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + +#ifdef SMIOL_PNETCDF + io_group_comm = MPI_Comm_f2c(file->io_group_comm); + + /* + * If the file is in define mode then switch it into data mode + */ + if (file->state == PNETCDF_DEFINE_MODE) { + if (file->io_task) { + ierr = ncmpi_enddef(file->ncidp); + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } + file->state = PNETCDF_DATA_MODE; + } + + if (file->io_task) { + ierr = NC_NOERR; + + if (file->n_reqs > 0) { + int statuses[MAX_REQS]; + + ierr = ncmpi_wait_all(file->ncidp, file->n_reqs, + file->reqs, statuses); + file->n_reqs = 0; + } + + if (ierr == NC_NOERR) { + ierr = ncmpi_sync(file->ncidp); + } + } + MPI_Bcast(&ierr, 1, MPI_INT, 0, io_group_comm); + if (ierr != NC_NOERR) { + file->context->lib_type = SMIOL_LIBRARY_PNETCDF; + file->context->lib_ierr = ierr; + return SMIOL_LIBRARY_ERROR; + } +#endif + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * SMIOL_error_string + * + * Returns an error string for a specified error code. + * + * Returns an error string corresponding to a SMIOL error code. If the error code is + * SMIOL_LIBRARY_ERROR and a valid SMIOL context is available, the SMIOL_lib_error_string + * function should be called instead. The error string is null-terminated, but it + * does not contain a newline character. + * + ********************************************************************************/ +const char *SMIOL_error_string(int errno) +{ + switch (errno) { + case SMIOL_SUCCESS: + return "Success!"; + case SMIOL_MALLOC_FAILURE: + return "malloc returned a null pointer"; + case SMIOL_INVALID_ARGUMENT: + return "invalid subroutine argument"; + case SMIOL_MPI_ERROR: + return "internal MPI call failed"; + case SMIOL_FORTRAN_ERROR: + return "Fortran wrapper detected an inconsistency in C return values"; + case SMIOL_LIBRARY_ERROR: + return "bad return code from a library call"; + case SMIOL_WRONG_ARG_TYPE: + return "argument is of the wrong type"; + case SMIOL_INSUFFICIENT_ARG: + return "argument is of insufficient size"; + default: + return "Unknown error"; + } +} + + +/******************************************************************************** + * + * SMIOL_lib_error_string + * + * Returns an error string for a third-party library called by SMIOL. + * + * Returns an error string corresponding to an error that was generated by + * a third-party library that was called by SMIOL. The library that was the source + * of the error, as well as the library-specific error code, are retrieved from + * a SMIOL context. If successive library calls resulted in errors, only the error + * string for the last of these errors will be returned. The error string is + * null-terminated, but it does not contain a newline character. + * + ********************************************************************************/ +const char *SMIOL_lib_error_string(struct SMIOL_context *context) +{ + if (context == NULL) { + return "SMIOL_context argument is a NULL pointer"; + } + + switch (context->lib_type) { +#ifdef SMIOL_PNETCDF + case SMIOL_LIBRARY_PNETCDF: + return ncmpi_strerror(context->lib_ierr); +#endif + default: + return "Could not find matching library for the source of the error"; + } +} + + +/******************************************************************************** + * + * SMIOL_set_option + * + * Sets an option for the SMIOL library. + * + * Detailed description. + * + ********************************************************************************/ +int SMIOL_set_option(void) +{ + return SMIOL_SUCCESS; +} + +/******************************************************************************** + * + * SMIOL_set_frame + * + * Set the frame for the unlimited dimension for an open file + * + * For an open SMIOL file handle, set the frame for the unlimited dimension. + * After setting the frame for a file, writing to a variable that is + * dimensioned by the unlimited dimension will write to the last set frame, + * overwriting any current data that maybe present in that frame. + * + * SMIOL_SUCCESS will be returned if the frame is successfully set otherwise an + * error will return. + * + ********************************************************************************/ +int SMIOL_set_frame(struct SMIOL_file *file, SMIOL_Offset frame) +{ + if (file == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + file->frame = frame; + return SMIOL_SUCCESS; +} + +/******************************************************************************** + * + * SMIOL_get_frame + * + * Return the current frame of an open file + * + * Get the current frame of an open file. Upon success, SMIOL_SUCCESS will be + * returned, otherwise an error will be returned. + * + ********************************************************************************/ +int SMIOL_get_frame(struct SMIOL_file *file, SMIOL_Offset *frame) +{ + if (file == NULL || frame == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + *frame = file->frame; + return SMIOL_SUCCESS; +} + + +/******************************************************************************* + * + * SMIOL_create_decomp + * + * Creates a mapping between compute elements and I/O elements. + * + * Given arrays of global element IDs that each task computes, this routine + * works out a mapping of elements between compute and I/O tasks. + * + * The aggregation factor is used to indicate the size of subsets of ranks + * that will gather fields onto a single rank in each subset before transferring + * that field from compute to output tasks; in a symmetric way, it also + * indicates the size of subsets over which fields will be scattered after they + * are transferred from input tasks to a single compute tasks in each subset. + * + * An aggregation factor of 0 indicates that the implementation should choose + * a suitable aggregation factor (usually matching the size of shared-memory + * domains), while a positive integer specifies a specific size for task groups + * to be used for aggregation. + * + * If all input arguments are determined to be valid and if the routine is + * successful in working out a mapping, the decomp pointer is allocated and + * given valid contents, and SMIOL_SUCCESS is returned; otherwise a non-success + * error code is returned and the decomp pointer is NULL. + * + *******************************************************************************/ +int SMIOL_create_decomp(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + int aggregation_factor, + struct SMIOL_decomp **decomp) +{ + size_t i; + size_t n_io_elements, n_io_elements_global; + size_t io_start, io_count; + SMIOL_Offset *io_elements; + MPI_Comm comm; + MPI_Datatype dtype; + int ierr; + + size_t n_compute_elements_agg; + SMIOL_Offset *compute_elements_agg = NULL; + MPI_Comm agg_comm = MPI_COMM_NULL; + int *counts = NULL; + int *displs = NULL; + int actual_agg_factor; + + + /* + * Minimal check on the validity of arguments + */ + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + if (compute_elements == NULL && n_compute_elements != 0) { + return SMIOL_INVALID_ARGUMENT; + } + + if (aggregation_factor < 0) { + return SMIOL_INVALID_ARGUMENT; + } + + comm = MPI_Comm_f2c(context->fcomm); + + /* + * Figure out MPI_Datatype for size_t... there must be a better way... + */ + switch (sizeof(size_t)) { + case sizeof(uint64_t): + dtype = MPI_UINT64_T; + break; + case sizeof(uint32_t): + dtype = MPI_UINT32_T; + break; + case sizeof(uint16_t): + dtype = MPI_UINT16_T; + break; + default: + return SMIOL_MPI_ERROR; + } + + /* + * Based on the number of compute elements for each task, determine + * the total number of elements across all tasks for I/O. The assumption + * is that the number of elements to read/write is equal to the size of + * the set of compute elements. + */ + n_io_elements = n_compute_elements; + if (MPI_SUCCESS != MPI_Allreduce((const void *)&n_io_elements, + (void *)&n_io_elements_global, + 1, dtype, MPI_SUM, comm)) { + return SMIOL_MPI_ERROR; + } + + /* + * Determine the contiguous range of elements to be read/written by + * this MPI task + */ + ierr = get_io_elements(context->comm_rank, + context->num_io_tasks, context->io_stride, + n_io_elements_global, &io_start, &io_count); + + /* + * Fill in io_elements from io_start through io_start + io_count - 1 + */ + io_elements = NULL; + if (io_count > 0) { + io_elements = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) + * n_io_elements_global); + if (io_elements == NULL) { + return SMIOL_MALLOC_FAILURE; + } + for (i = 0; i < io_count; i++) { + io_elements[i] = (SMIOL_Offset)(io_start + i); + } + } + + /* + * If aggregation_factor != 1, aggregate the list of compute_elements + * before building the mapping + */ + if (aggregation_factor != 1) { + int comm_rank = context->comm_rank; + + /* + * Create intracommunicators for aggregation + */ + if (aggregation_factor == 0) { + ierr = MPI_Comm_split_type(comm, MPI_COMM_TYPE_SHARED, + comm_rank, MPI_INFO_NULL, + &agg_comm); + } else { + ierr = MPI_Comm_split(comm, + (comm_rank / aggregation_factor), + comm_rank, + &agg_comm); + } + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_split failed with code %i\n", + ierr); + return SMIOL_MPI_ERROR; + } + + ierr = MPI_Comm_size(agg_comm, &actual_agg_factor); + if (ierr != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_size failed with code %i\n", + ierr); + return SMIOL_MPI_ERROR; + } + + /* + * Create aggregated compute_elements list if the actual + * aggregation factor is > 1 + */ + if (actual_agg_factor > 1) { + aggregate_list(agg_comm, 0, n_compute_elements, + compute_elements, + &n_compute_elements_agg, + &compute_elements_agg, &counts, &displs); + } else { + MPI_Comm_free(&agg_comm); + n_compute_elements_agg = n_compute_elements; + compute_elements_agg = compute_elements; + } + } else { + actual_agg_factor = 1; + n_compute_elements_agg = n_compute_elements; + compute_elements_agg = compute_elements; + } + + /* + * Build the mapping between compute tasks and I/O tasks + */ + ierr = build_exchange(context, + n_compute_elements_agg, compute_elements_agg, + io_count, io_elements, + decomp); + + free(io_elements); + + if (actual_agg_factor > 1) { + (*decomp)->agg_factor = actual_agg_factor; + (*decomp)->agg_comm = MPI_Comm_c2f(agg_comm); + (*decomp)->n_compute = n_compute_elements; + (*decomp)->n_compute_agg = n_compute_elements_agg; + (*decomp)->counts = counts; + (*decomp)->displs = displs; + + free(compute_elements_agg); + } + + /* + * If decomp was successfully created, add io_start and io_count values + * to the decomp before returning + */ + if (ierr == SMIOL_SUCCESS) { + (*decomp)->io_start = io_start; + (*decomp)->io_count = io_count; + } + + return ierr; +} + + +/******************************************************************************** + * + * SMIOL_free_decomp + * + * Frees a mapping between compute elements and I/O elements. + * + * Free all memory of a SMIOL_decomp and returns SMIOL_SUCCESS. If decomp + * points to NULL, then do nothing and return SMIOL_SUCCESS. After this routine + * is called, no other SMIOL routines should use the freed SMIOL_decomp. + * + ********************************************************************************/ +int SMIOL_free_decomp(struct SMIOL_decomp **decomp) +{ + MPI_Comm comm; + + if ((*decomp) == NULL) { + return SMIOL_SUCCESS; + } + + free((*decomp)->comp_list); + free((*decomp)->io_list); + + comm = MPI_Comm_f2c((*decomp)->agg_comm); + if (comm != MPI_COMM_NULL) { + MPI_Comm_free(&comm); + } + if ((*decomp)->counts != NULL) { + free((*decomp)->counts); + } + if ((*decomp)->displs != NULL) { + free((*decomp)->displs); + } + + free((*decomp)); + *decomp = NULL; + + return SMIOL_SUCCESS; +} + + +/******************************************************************************** + * + * build_start_count + * + * Constructs start[] and count[] arrays for parallel I/O operations + * + * Given a pointer to a SMIOL file that was previously opened, the name of + * a variable in that file, and a SMIOL decomp, this function returns several + * items that may be used when reading or writing the variable in parallel: + * + * 1) The size of each "element" of the variable, where an element is defined as + * a contiguous memory range associated with the slowest-varying, non-record + * dimension of the variable; for example, a variable + * float foo[nCells][nVertLevels] would have an element size of + * sizeof(float) * nVertLevels if nCells were a decomposed dimension. + * + * For non-decomposed variables, the element size is the size of one record + * of the entire variable. + * + * 2) The size of the fundamental datatype for the variable; for example, a + * float variable would yield sizeof(float). + * + * 3) The number of dimensions for the variable, including any unlimited/record + * dimension. + * + * 4) Whether the variable has a record (unlimited) dimension. + * + * 5) The start[] and count[] arrays (each with size ndims) to be read or written + * by an MPI rank using the I/O decomposition described in decomp. + * + * If the decomp argument is NULL, the variable is to be read or written as + * a non-decomposed variable; typically, only MPI rank 0 will write + * the non-decomposed variable, and all MPI ranks will read the non-decomposed + * variable. + * + * Depending on the value of the write_or_read argument -- either START_COUNT_READ + * or START_COUNT_WRITE -- the count[] values will be set so that all ranks will + * read the variable, or only rank 0 will write the variable if the variable is + * not decomposed. + * + ********************************************************************************/ +int build_start_count(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, + int write_or_read, size_t *element_size, + size_t *basic_type_size, int *ndims, + int *has_unlimited_dim, + size_t **start, size_t **count) +{ + int i; + int ierr; + int vartype; + char **dimnames; + SMIOL_Offset *dimsizes; + +/* TO DO - define maximum string size, currently assumed to be 64 chars */ + + /* + * Figure out type of the variable, as well as its dimensions + */ + ierr = SMIOL_inquire_var(file, varname, &vartype, ndims, NULL); + if (ierr != SMIOL_SUCCESS) { + return ierr; + } + + dimnames = malloc(sizeof(char *) * (size_t)(*ndims)); + if (dimnames == NULL) { + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + for (i = 0; i < *ndims; i++) { + dimnames[i] = malloc(sizeof(char) * (size_t)64); + if (dimnames[i] == NULL) { + int j; + + for (j = 0; j < i; j++) { + free(dimnames[j]); + } + free(dimnames); + + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + } + + ierr = SMIOL_inquire_var(file, varname, NULL, NULL, dimnames); + if (ierr != SMIOL_SUCCESS) { + for (i = 0; i < *ndims; i++) { + free(dimnames[i]); + } + free(dimnames); + return ierr; + } + + dimsizes = malloc(sizeof(SMIOL_Offset) * (size_t)(*ndims)); + if (dimsizes == NULL) { + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + /* + * It is assumed that only the first dimension can be an unlimited + * dimension, so by inquiring about dimensions from last to first, we + * can be guaranteed that has_unlimited_dim will be set correctly at + * the end of the loop over dimensions + */ + *has_unlimited_dim = 0; + for (i = (*ndims-1); i >= 0; i--) { + ierr = SMIOL_inquire_dim(file, dimnames[i], &dimsizes[i], + has_unlimited_dim); + if (ierr != SMIOL_SUCCESS) { + for (i = 0; i < *ndims; i++) { + free(dimnames[i]); + } + free(dimnames); + free(dimsizes); + + return ierr; + } + } + + for (i = 0; i < *ndims; i++) { + free(dimnames[i]); + } + free(dimnames); + + /* + * Set basic size of each element in the field + */ + *element_size = 1; + switch (vartype) { + case SMIOL_REAL32: + *basic_type_size = sizeof(float); + break; + case SMIOL_REAL64: + *basic_type_size = sizeof(double); + break; + case SMIOL_INT32: + *basic_type_size = sizeof(int); + break; + case SMIOL_CHAR: + *basic_type_size = sizeof(char); + break; + } + *element_size = *basic_type_size; + + *start = malloc(sizeof(size_t) * (size_t)(*ndims)); + if (*start == NULL) { + free(dimsizes); + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + *count = malloc(sizeof(size_t) * (size_t)(*ndims)); + if (*count == NULL) { + free(dimsizes); + free(start); + ierr = SMIOL_MALLOC_FAILURE; + return ierr; + } + + /* + * Build start/count description of the part of the variable to be + * read or written. Simultaneously, compute the product of all + * non-unlimited, non-decomposed dimension sizes, scaled by the basic + * element size to get the effective size of each element to be read or + * written + */ + for (i = 0; i < *ndims; i++) { + (*start)[i] = (size_t)0; + (*count)[i] = (size_t)dimsizes[i]; + + /* + * If variable has an unlimited dimension, set start to current + * frame and count to one + */ + if (*has_unlimited_dim && i == 0) { + (*start)[i] = (size_t)file->frame; + (*count)[i] = (size_t)1; + } + + /* + * If variable is decomposed, set the slowest-varying, + * non-record dimension start and count based on values from + * the decomp structure + */ + if (decomp) { + if ((!*has_unlimited_dim && i == 0) || + (*has_unlimited_dim && i == 1)) { + (*start)[i] = decomp->io_start; + (*count)[i] = decomp->io_count; + } else { + *element_size *= (*count)[i]; + } + } else { + *element_size *= (*count)[i]; + } + + if (write_or_read == START_COUNT_WRITE) { + /* + * If the variable is not decomposed, only MPI rank 0 + * will have non-zero count values so that all MPI ranks + * do no try to write the same offsets + */ + if (!decomp && file->context->comm_rank != 0) { + (*count)[i] = 0; + } + } + } + + free(dimsizes); + + return SMIOL_SUCCESS; +} + + +#ifdef SMIOL_PNETCDF +/******************************************************************************** + * + * write_chunk_pnetcdf + * + * Write a chunk of a variable to a file using the Parallel-NetCDF library + * + * Given a file and information about a variable in the file, write a chunk of + * memory to the variable according to start/count arrays. If the size of the + * chunk to be written will fit within any buffer attached to the file, the + * chunk is written using the Parallel-NetCDF buffered non-blocking interface; + * otherwise, the chunk is written using the blocking write interface, ensuring + * that not more than 2 GiB is written in any single call to ncmpi_put_vara_all. + * + * The return value from this function will be NC_NOERR in case no errors + * occurred in calls to the Parallel-NetCDF library, or a Parallel-NetCDF error + * code otherwise. + * + * Within this function, return error codes from MPI calls are ignored. + * + ********************************************************************************/ +int write_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + const void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ) +{ + int ierr = NC_NOERR; + long lusage; + long max_usage; + size_t element_size; + int iter_idx; + int i; + + /* + * For scalar variables (with or without an unlimited dimension), + * just write with a single call to the blocking write interface. + */ + if (ndims == 0 || (has_unlimited_dim && ndims == 1)) { + ierr = ncmpi_bput_vara(file->ncidp, + varidp, + mpi_start, mpi_count, + buf_p, + 0, MPI_DATATYPE_NULL, + &(file->reqs[(file->n_reqs++)])); + return ierr; + } + + /* + * Set iter_idx to be the slowest-varying non-record (non-unlimited) + * dimension for the variable + */ + iter_idx = 0; + if (has_unlimited_dim) iter_idx++; + + /* + * Let element_size be the product of the fastest-varying dimension + * sizes beyond the iter_idx dimension multiplied by the basic type + * size for this variable. + */ + element_size = basic_type_size; + for (i = iter_idx + 1; i < ndims; i++) { + element_size *= mpi_count[i]; + } + + /* + * Compute the maximum total number of bytes to be written by any MPI + * task for their chunks of the variable + */ + lusage = (long)element_size * mpi_count[iter_idx]; + MPI_Allreduce(&lusage, &max_usage, 1, MPI_LONG, + MPI_MAX, io_file_comm); + + /* + * If the maximum size of a chunk of data to be written is larger than + * the buffer size, just write through the non-buffered interface; + * otherwise, the ncmpi_bput_vara call will fail. + */ + if (max_usage > file->bufsize || max_usage > ((MPI_Offset)INT_MAX)) { + MPI_Offset remaining_count; + MPI_Offset max_count; + long done, global_done; + size_t buf_offset; + + max_count = ((MPI_Offset)INT_MAX) / element_size; + remaining_count = mpi_count[iter_idx]; + + /* + * Bound the number of values to be written along the slowest- + * varying non-record dimension to ensure that not more than + * 2 GiB are written in the call to ncmpi_put_vara_all + */ + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + remaining_count -= mpi_count[iter_idx]; + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + global_done = 0; + buf_offset = 0; + + /* + * Keep calling ncmpi_put_vara_all on all I/O tasks as long as + * at least one task still has data to be written, writing at + * most 2 GiB at a time + */ + while (!global_done) { + ierr = ncmpi_put_vara_all(file->ncidp, + varidp, + mpi_start, mpi_count, + &((uint8_t *)buf_p)[buf_offset], + 0, MPI_DATATYPE_NULL); + + /* + * Update start/count values for slowest non-record + * dimension, and determine whether this task still has + * data to be written + */ + if (!done) { + buf_offset += (size_t)mpi_count[iter_idx] + * element_size; + mpi_start[iter_idx] += mpi_count[iter_idx]; + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + remaining_count -= mpi_count[iter_idx]; + + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + } + + if (ierr != NC_NOERR) { + done = -1; + } + + /* + * Get done status across all I/O tasks + */ + MPI_Allreduce(&done, &global_done, 1, MPI_LONG, MPI_MIN, + MPI_Comm_f2c(file->io_file_comm)); + }; + + } else { + /* + * If executing this else branch, assume bufsize > 0 and + * that a buffer has therefore been attached to file. + */ + + MPI_Offset usage; + + /* + * Check how many bytes have been used in buffer on this task + */ + ierr = ncmpi_inq_buffer_usage(file->ncidp, + &usage); + lusage = usage + + (long)element_size * mpi_count[iter_idx]; + + MPI_Allreduce(&lusage, &max_usage, 1, + MPI_LONG, MPI_MAX, + io_file_comm); + + /* + * If making a buffered write would cause the remaining buffer + * size to be exceeded on any task, wait for non-blocking + * writes to complete + */ + if ((size_t)max_usage > file->bufsize + || file->n_reqs == MAX_REQS) { + ierr = ncmpi_wait_all(file->ncidp, file->n_reqs, + file->reqs, NULL); /* statuses */ + file->n_reqs = 0; + } + + if (ierr == NC_NOERR) { + ierr = ncmpi_bput_vara(file->ncidp, + varidp, + mpi_start, mpi_count, + buf_p, + 0, MPI_DATATYPE_NULL, + &(file->reqs[(file->n_reqs++)])); + } + } + + return ierr; +} + + +/******************************************************************************** + * + * read_chunk_pnetcdf + * + * Read a chunk of a variable from a file using the Parallel-NetCDF library + * + * Given a file and information about a variable in the file, read a chunk of + * memory from the variable according to start/count arrays. The chunk is always + * read using the blocking read interface while ensuring that not more than 2 + * GiB is read in any single call to ncmpi_get_vara_all. + * + * The return value from this function will be NC_NOERR in case no errors + * occurred in calls to the Parallel-NetCDF library, or a Parallel-NetCDF error + * code otherwise. + * + * Within this function, return error codes from MPI calls are ignored. + * + ********************************************************************************/ +int read_chunk_pnetcdf(struct SMIOL_file *file, + int varidp, + int ndims, + int has_unlimited_dim, + size_t basic_type_size, + MPI_Comm io_file_comm, + void *buf_p, + MPI_Offset *mpi_start, + MPI_Offset *mpi_count + ) +{ + int ierr = NC_NOERR; + int iter_idx; + MPI_Offset remaining_count; + MPI_Offset max_count; + long done, global_done; + size_t element_size; + size_t buf_offset; + int i; + + /* + * For scalar variables (with or without an unlimited dimension), + * just read with a single call to the blocking read interface. + */ + if (ndims == 0 || (has_unlimited_dim && ndims == 1)) { + ierr = ncmpi_get_vara_all(file->ncidp, + varidp, + mpi_start, mpi_count, + buf_p, + 0, MPI_DATATYPE_NULL); + return ierr; + } + + /* + * Set iter_idx to be the slowest-varying non-record (non-unlimited) + * dimension for the variable + */ + iter_idx = 0; + if (has_unlimited_dim) iter_idx++; + + /* + * Let element_size be the product of the fastest-varying dimension + * sizes beyond the iter_idx dimension multiplied by the basic type + * size for this variable. + */ + element_size = basic_type_size; + for (i = iter_idx + 1; i < ndims; i++) { + element_size *= mpi_count[i]; + } + + max_count = ((MPI_Offset)INT_MAX) / element_size; + remaining_count = mpi_count[iter_idx]; + + /* + * Bound the number of values to be read along the slowest-varying + * non-record dimension to ensure that not more than 2 GiB are read + * in the call to ncmpi_get_vara_all + */ + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + + remaining_count -= mpi_count[iter_idx]; + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + global_done = 0; + buf_offset = 0; + + /* + * Keep calling ncmpi_get_vara_all on all I/O tasks as long as at least + * one task still has data to be read, reading at most 2 GiB at a time + */ + while (!global_done) { + ierr = ncmpi_get_vara_all(file->ncidp, + varidp, + mpi_start, mpi_count, + &((uint8_t *)buf_p)[buf_offset], + 0, MPI_DATATYPE_NULL); + + /* + * Update start/count values for slowest non-record dimension, + * and determine whether this task still has data to be read + */ + if (!done) { + buf_offset += (size_t)mpi_count[iter_idx] * element_size; + mpi_start[iter_idx] += mpi_count[iter_idx]; + mpi_count[iter_idx] = (max_count < remaining_count) + ? max_count : remaining_count; + remaining_count -= mpi_count[iter_idx]; + + done = (mpi_count[iter_idx] == 0) ? 1 : 0; + } + + if (ierr != NC_NOERR) { + done = -1; + } + + /* + * Get done status across all I/O tasks + */ + MPI_Allreduce(&done, &global_done, 1, MPI_LONG, MPI_MIN, + io_file_comm); + }; + + return ierr; +} +#endif diff --git a/src/external/SMIOL/smiol.h b/src/external/SMIOL/smiol.h new file mode 100644 index 0000000000..42589d9797 --- /dev/null +++ b/src/external/SMIOL/smiol.h @@ -0,0 +1,73 @@ +/******************************************************************************* + * SMIOL -- The Simple MPAS I/O Library + *******************************************************************************/ +#ifndef SMIOL_H +#define SMIOL_H + +#include "smiol_types.h" + + +/* + * Library methods + */ +int SMIOL_fortran_init(MPI_Fint comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context); +int SMIOL_init(MPI_Comm comm, int num_io_tasks, int io_stride, + struct SMIOL_context **context); +int SMIOL_finalize(struct SMIOL_context **context); +int SMIOL_inquire(void); + +/* + * File methods + */ +int SMIOL_open_file(struct SMIOL_context *context, const char *filename, + int mode, struct SMIOL_file **file, size_t bufsize); +int SMIOL_close_file(struct SMIOL_file **file); + +/* + * Dimension methods + */ +int SMIOL_define_dim(struct SMIOL_file *file, const char *dimname, SMIOL_Offset dimsize); +int SMIOL_inquire_dim(struct SMIOL_file *file, const char *dimname, + SMIOL_Offset *dimsize, int *is_unlimited); + +/* + * Variable methods + */ +int SMIOL_define_var(struct SMIOL_file *file, const char *varname, int vartype, int ndims, const char **dimnames); +int SMIOL_inquire_var(struct SMIOL_file *file, const char *varname, int *vartype, int *ndims, char **dimnames); +int SMIOL_put_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, const void *buf); +int SMIOL_get_var(struct SMIOL_file *file, const char *varname, + const struct SMIOL_decomp *decomp, void *buf); + +/* + * Attribute methods + */ +int SMIOL_define_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int att_type, const void *att); + +int SMIOL_inquire_att(struct SMIOL_file *file, const char *varname, + const char *att_name, int *att_type, + SMIOL_Offset *att_len, void *att); + +/* + * Control methods + */ +int SMIOL_sync_file(struct SMIOL_file *file); +const char *SMIOL_error_string(int errno); +const char *SMIOL_lib_error_string(struct SMIOL_context *context); +int SMIOL_set_option(void); +int SMIOL_set_frame(struct SMIOL_file *file, SMIOL_Offset frame); +int SMIOL_get_frame(struct SMIOL_file *file, SMIOL_Offset *frame); + +/* + * Decomposition methods + */ +int SMIOL_create_decomp(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + int aggregation_factor, + struct SMIOL_decomp **decomp); +int SMIOL_free_decomp(struct SMIOL_decomp **decomp); + +#endif diff --git a/src/external/SMIOL/smiol_codes.inc b/src/external/SMIOL/smiol_codes.inc new file mode 100644 index 0000000000..456bcc7bed --- /dev/null +++ b/src/external/SMIOL/smiol_codes.inc @@ -0,0 +1,21 @@ +#define SMIOL_SUCCESS (0) +#define SMIOL_MALLOC_FAILURE (-1) +#define SMIOL_INVALID_ARGUMENT (-2) +#define SMIOL_MPI_ERROR (-3) +#define SMIOL_FORTRAN_ERROR (-4) +#define SMIOL_LIBRARY_ERROR (-5) +#define SMIOL_WRONG_ARG_TYPE (-6) +#define SMIOL_INSUFFICIENT_ARG (-7) + +#define SMIOL_FILE_CREATE (1) +#define SMIOL_FILE_READ (2) +#define SMIOL_FILE_WRITE (4) + +#define SMIOL_LIBRARY_UNKNOWN (1000) +#define SMIOL_LIBRARY_PNETCDF (1001) + +#define SMIOL_REAL32 (2000) +#define SMIOL_REAL64 (2001) +#define SMIOL_INT32 (2002) +#define SMIOL_CHAR (2003) +#define SMIOL_UNKNOWN_VAR_TYPE (2004) diff --git a/src/external/SMIOL/smiol_types.h b/src/external/SMIOL/smiol_types.h new file mode 100644 index 0000000000..015faebef5 --- /dev/null +++ b/src/external/SMIOL/smiol_types.h @@ -0,0 +1,85 @@ +/******************************************************************************* + * SMIOL -- The Simple MPAS I/O Library + *******************************************************************************/ +#ifndef SMIOL_TYPES_H +#define SMIOL_TYPES_H + +#include +#include "mpi.h" + + +/* If SMIOL_Offset is redefined, interoperable Fortran types and interfaces must also be updated */ +typedef int64_t SMIOL_Offset; + + +#define TRIPLET_SIZE ((size_t)3) + + +/* + * Types + */ +struct SMIOL_context { + MPI_Fint fcomm; /* Fortran handle to MPI communicator */ + int comm_size; /* Size of MPI communicator */ + int comm_rank; /* Rank within MPI communicator */ + + int num_io_tasks; /* The number of I/O tasks */ + int io_stride; /* The stride between I/O tasks in the communicator */ + + int lib_ierr; /* Library-specific error code */ + int lib_type; /* From which library the error code originated */ +}; + +struct SMIOL_file { + struct SMIOL_context *context; /* Context for this file */ + SMIOL_Offset frame; /* Current frame of the file */ +#ifdef SMIOL_PNETCDF + int state; /* parallel-netCDF file state (i.e. Define or data mode) */ + int ncidp; /* parallel-netCDF file handle */ + size_t bufsize; /* Size of buffer attached to this file */ + int n_reqs; /* Number of pending non-blocking requests */ + int *reqs; /* Array of pending non-blocking request handles */ +#endif + int io_task; /* 1 = this task performs I/O calls + 0 = no I/O calls on this task */ + MPI_Fint io_file_comm; /* Communicator shared by all tasks with + io_task == 1 */ + MPI_Fint io_group_comm; /* Communicator shared by tasks associated with + an I/O task, usually 1 I/O task and N-1 + non-I/O tasks, where N is the I/O stride */ +}; + +struct SMIOL_decomp { + /* + * The lists below are structured as follows: + * list[0] - the number of neighbors for which a task sends/recvs + * | + * list[n] - neighbor task ID | repeated for + * list[n+1] - number of elements, m, to send/recv to/from the neighbor | each neighbor + * list[n+2 .. n+2+m] - local element IDs to send/recv to/from the neighbor | + * | + */ + SMIOL_Offset *comp_list; /* Elements to be sent/received from/on a compute task */ + SMIOL_Offset *io_list; /* Elements to be sent/received from/on an I/O task */ + + struct SMIOL_context *context; /* Context for this decomp */ + + size_t io_start; /* The starting offset on disk for I/O by a task */ + size_t io_count; /* The number of elements for I/O by a task */ + + int agg_factor; /* Aggregation factor, or size of aggregation group */ + MPI_Fint agg_comm; /* Communicator for aggregation/deaggregation operations */ + size_t n_compute; /* Number of un-aggregated compute elements on the task */ + size_t n_compute_agg; /* Number of aggregated compute elements on the task */ + int *counts; /* Compute element counts for tasks in aggregation group */ + int *displs; /* Displacements in aggregated list of elements for tasks */ + /* in aggregation group */ +}; + + +/* + * Return error codes + */ +#include "smiol_codes.inc" + +#endif diff --git a/src/external/SMIOL/smiol_utils.c b/src/external/SMIOL/smiol_utils.c new file mode 100644 index 0000000000..9a9b35282a --- /dev/null +++ b/src/external/SMIOL/smiol_utils.c @@ -0,0 +1,1263 @@ +#include +#include +#include "smiol_utils.h" + +/* + * Prototypes for functions used only internally by SMIOL utilities + */ +static int comp_sort_0(const void *a, const void *b); +static int comp_sort_1(const void *a, const void *b); +static int comp_sort_2(const void *a, const void *b); +static int comp_search_0(const void *a, const void *b); +static int comp_search_1(const void *a, const void *b); +static int comp_search_2(const void *a, const void *b); + + +/******************************************************************************* + * + * sort_triplet_array + * + * Sorts an array of triplets of SMIOL_Offset values in ascending order + * + * Given a pointer to an array of SMIOL_Offset triplets, sorts the array in + * ascending order on the specified entry: 0 sorts on the first value in + * the triplets, 1 sorts on the second value, and 2 sorts on the third. + * + * If the sort_entry is 1 or 2, the relative position of two triplets whose + * values in that entry match will be determined by their values in the first + * entry. + * + * The sort is not guaranteed to be stable. + * + *******************************************************************************/ +void sort_triplet_array(size_t n_arr, SMIOL_Offset *arr, int sort_entry) +{ + size_t width = sizeof(SMIOL_Offset) * TRIPLET_SIZE; + + switch (sort_entry) { + case 0: + qsort((void *)arr, n_arr, width, comp_sort_0); + break; + case 1: + qsort((void *)arr, n_arr, width, comp_sort_1); + break; + case 2: + qsort((void *)arr, n_arr, width, comp_sort_2); + break; + } +} + + +/******************************************************************************* + * + * search_triplet_array + * + * Searches a sorted array of triplets of SMIOL_Offset values + * + * Given a pointer to a sorted array of SMIOL_Offset triplets, searches + * the array on the specified entry for the key value. A search_entry value of + * 0 searches for the key in the first entry of each triplet, 1 searches in + * the second entry, and 2 searches in the third. + * + * If the key is found, the address of the triplet will be returned; otherwise, + * a NULL pointer is returned. + * + * If the key occurs in more than one triplet at the specified entry, there is + * no guarantee as to which triplet's address will be returned. + * + *******************************************************************************/ +SMIOL_Offset *search_triplet_array(SMIOL_Offset key, + size_t n_arr, SMIOL_Offset *arr, + int search_entry) +{ + SMIOL_Offset *res; + SMIOL_Offset key3[TRIPLET_SIZE]; + size_t width = sizeof(SMIOL_Offset) * TRIPLET_SIZE; + + key3[search_entry] = key; + + switch (search_entry) { + case 0: + res = (SMIOL_Offset *)bsearch((const void *)&key3, + (const void *)arr, n_arr, + width, comp_search_0); + break; + case 1: + res = (SMIOL_Offset *)bsearch((const void *)&key3, + (const void *)arr, n_arr, + width, comp_search_1); + break; + case 2: + res = (SMIOL_Offset *)bsearch((const void *)&key3, + (const void *)arr, n_arr, + width, comp_search_2); + break; + default: + res = NULL; + } + + return res; +} + + +/******************************************************************************* + * + * transfer_field + * + * Transfers a field between compute and I/O tasks + * + * Given a SMIOL_decomp and a direction, which determines whether the input + * field is transferred from compute tasks to I/O tasks or from I/O tasks to + * compute tasks, this function transfers the input field to the output field. + * + * The size in bytes of the elements in the field to be transferred is given by + * element_size; for example, a single-precision field would set element_size + * to sizeof(float). + * + * The caller must have already allocated the out_field argument with sufficient + * space to contain the field. + * + * If no errors are detected in the input arguments or in the transfer of + * the input field to the output field, SMIOL_SUCCESS is returned. + * + *******************************************************************************/ +int transfer_field(const struct SMIOL_decomp *decomp, int dir, + size_t element_size, const void *in_field, void *out_field) +{ + MPI_Comm comm; + int comm_rank; + + SMIOL_Offset *sendlist = NULL; + SMIOL_Offset *recvlist = NULL; + + MPI_Request *send_reqs = NULL; + MPI_Request *recv_reqs = NULL; + + uint8_t **send_bufs = NULL; + uint8_t **recv_bufs = NULL; + uint8_t *in_bytes = NULL; + uint8_t *out_bytes = NULL; + + size_t ii, kk; + size_t n_neighbors_send; + size_t n_neighbors_recv; + int64_t pos; + int64_t pos_src = -1; + int64_t pos_dst = -1; + + /* + * The following are ints because they correspond to MPI arguments + * that are ints, or they iterate over an int bound + */ + int taskid; + int n_send, n_recv; + int j; + + + if (decomp == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + comm = MPI_Comm_f2c(decomp->context->fcomm); + comm_rank = decomp->context->comm_rank; + + /* + * Throughout this function, operate on the fields as arrays of bytes + */ + in_bytes = (uint8_t *)in_field; + out_bytes = (uint8_t *)out_field; + + /* + * Set send and recv lists based on exchange direction + */ + if (dir == SMIOL_COMP_TO_IO) { + sendlist = decomp->comp_list; + recvlist = decomp->io_list; + } else if (dir == SMIOL_IO_TO_COMP) { + sendlist = decomp->io_list; + recvlist = decomp->comp_list; + } else { + return SMIOL_INVALID_ARGUMENT; + } + + /* + * Determine how many other MPI tasks to communicate with, and allocate + * request lists and buffer pointers + */ + n_neighbors_send = (size_t)(sendlist[0]); + n_neighbors_recv = (size_t)(recvlist[0]); + + /* + * Check that we have non-NULL in_field and out_field arguments + * in agreement with the number of neighbors to send/recv to/from + */ + if ((in_field == NULL && n_neighbors_send != 0) + || (out_field == NULL && n_neighbors_recv != 0)) { + return SMIOL_INVALID_ARGUMENT; + } + + send_reqs = (MPI_Request *)malloc(sizeof(MPI_Request) + * n_neighbors_send); + recv_reqs = (MPI_Request *)malloc(sizeof(MPI_Request) + * n_neighbors_recv); + + send_bufs = (uint8_t **)malloc(sizeof(uint8_t *) * n_neighbors_send); + recv_bufs = (uint8_t **)malloc(sizeof(uint8_t *) * n_neighbors_recv); + + /* + * Post receives + */ + pos = 1; + for (ii = 0; ii < n_neighbors_recv; ii++) { + taskid = (int)recvlist[pos++]; + n_recv = (int)recvlist[pos++]; + if (taskid != comm_rank) { + recv_bufs[ii] = (uint8_t *)malloc(sizeof(uint8_t) + * element_size + * (size_t)n_recv); + + MPI_Irecv((void *)recv_bufs[ii], + n_recv * (int)element_size, + MPI_BYTE, taskid, comm_rank, comm, + &recv_reqs[ii]); + } + else { + /* + * This is a receive from ourself - save position in + * recvlist for local copy, below + */ + pos_dst = pos - 1; /* Offset of n_recv */ + recv_bufs[ii] = NULL; + } + pos += n_recv; + } + + /* + * Post sends + */ + pos = 1; + for (ii = 0; ii < n_neighbors_send; ii++) { + taskid = (int)sendlist[pos++]; + n_send = (int)sendlist[pos++]; + if (taskid != comm_rank) { + send_bufs[ii] = (uint8_t *)malloc(sizeof(uint8_t) + * element_size + * (size_t)n_send); + + /* Pack send buffer */ + for (j = 0; j < n_send; j++) { + size_t out_idx = (size_t)j + * element_size; + size_t in_idx = (size_t)sendlist[pos] + * element_size; + + for (kk = 0; kk < element_size; kk++) { + send_bufs[ii][out_idx + kk] = in_bytes[in_idx + kk]; + } + pos++; + } + + MPI_Isend((void *)send_bufs[ii], + n_send * (int)element_size, + MPI_BYTE, taskid, taskid, comm, + &send_reqs[ii]); + } + else { + /* + * This is a send to ourself - save position in + * sendlist for local copy, below + */ + pos_src = pos - 1; /* Offset of n_send */ + send_bufs[ii] = NULL; + pos += n_send; + } + } + + /* + * Handle local copies + */ + if (pos_src >= 0 && pos_dst >= 0) { + + /* n_send and n_recv should actually be identical */ + n_send = (int)sendlist[pos_src++]; + n_recv = (int)recvlist[pos_dst++]; + + for (j = 0; j < n_send; j++) { + size_t out_idx = (size_t)recvlist[pos_dst] + * element_size; + size_t in_idx = (size_t)sendlist[pos_src] + * element_size; + + for (kk = 0; kk < element_size; kk++) { + out_bytes[out_idx + kk] = in_bytes[in_idx + kk]; + } + pos_dst++; + pos_src++; + } + } + + /* + * Wait on receives + */ + pos = 1; + for (ii = 0; ii < n_neighbors_recv; ii++) { + taskid = (int)recvlist[pos++]; + n_recv = (int)recvlist[pos++]; + if (taskid != comm_rank) { + MPI_Wait(&recv_reqs[ii], MPI_STATUS_IGNORE); + + /* Unpack receive buffer */ + for (j = 0; j < n_recv; j++) { + size_t out_idx = (size_t)recvlist[pos] + * element_size; + size_t in_idx = (size_t)j + * element_size; + + for (kk = 0; kk < element_size; kk++) { + out_bytes[out_idx + kk] = recv_bufs[ii][in_idx + kk]; + } + pos++; + } + } + else { + /* + * A receive from ourself - just skip to next neighbor + * in the recvlist + */ + pos += n_recv; + } + + /* + * The receive buffer for the current neighbor can now be freed + */ + if (recv_bufs[ii] != NULL) { + free(recv_bufs[ii]); + } + } + + /* + * Wait on sends + */ + pos = 1; + for (ii = 0; ii < n_neighbors_send; ii++) { + taskid = (int)sendlist[pos++]; + n_send = (int)sendlist[pos++]; + if (taskid != comm_rank) { + MPI_Wait(&send_reqs[ii], MPI_STATUS_IGNORE); + } + + /* + * The send buffer for the current neighbor can now be freed + */ + if (send_bufs[ii] != NULL) { + free(send_bufs[ii]); + } + + pos += n_send; + } + + /* + * Free request lists and buffer pointers + */ + free(send_reqs); + free(recv_reqs); + free(send_bufs); + free(recv_bufs); + + return SMIOL_SUCCESS; +} + + +/******************************************************************************* + * + * aggregate_list + * + * Aggregates lists of elements from across all ranks onto a chosen root rank + * + * On entry, each MPI rank supplies a list of SMIOL_Offset values as well as the + * size of that input list. The input list may be zero size. + * + * Upon successful return, for the root rank, the out_list argument will point + * to an allocated array containing the aggregated elements from all MPI ranks + * in the communicator, and n_out will specify the number of elements in the + * output array. On all other ranks, n_out will be zero, and out_list will be a + * NULL pointer. + * + * Also on the root rank, the counts and displs arrays will be allocated with + * size equal to the size of the communicator, and they will contain the number + * of elements in the aggregated list from each MPI rank as well as the + * beginning offset in the aggregated list of elements from each rank. On all + * non-root ranks, counts and displs will be returned as NULL pointers. + * + * Although the number of elements in each input list is given by a size_t, + * the number of elements must not exceed the maximum representable value of + * a signed integer due to restrictions imposed by MPI argument types. + * Similarly, it must be ensured that the number of output elements does not + * exceed the maximum representable value of a signed integer. + * + * If no errors occurred, 0 is returned. Otherwise, a value of 1 is returned. + * + *******************************************************************************/ +int aggregate_list(MPI_Comm comm, int root, size_t n_in, SMIOL_Offset *in_list, + size_t *n_out, SMIOL_Offset **out_list, + int **counts, int **displs) +{ + int comm_size; + int comm_rank; + int err; + int i; + int n_in_i; + + + *n_out = 0; + *out_list = NULL; + + *counts = NULL; + *displs = NULL; + + n_in_i = (int)n_in; + + if (MPI_Comm_size(comm, &comm_size) != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_size failed in aggregate_list\n"); + return 1; + } + + if (MPI_Comm_rank(comm, &comm_rank) != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Comm_rank failed in aggregate_list\n"); + return 1; + } + + if (comm_rank == root) { + *counts = (int *)malloc(sizeof(int) * (size_t)(comm_size)); + *displs = (int *)malloc(sizeof(int) * (size_t)(comm_size)); + } + + /* + * Gather the number of input elements from all tasks onto root rank + */ + err = MPI_Gather((const void *)&n_in_i, 1, MPI_INT, + (void *)(*counts), 1, MPI_INT, root, comm); + if (err != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Gather failed in aggregate_list\n"); + return 1; + } + + /* + * Perform a scan of counts to get displs, and compute the number of + * output elements on root rank as the sum of the number of input + * elements across all tasks in the communicator + */ + if (comm_rank == root) { + (*displs)[0] = 0; + *n_out = (size_t)(*counts)[0]; + for (i = 1; i < comm_size; i++) { + (*displs)[i] = (*displs)[i-1] + (*counts)[i-1]; + *n_out += (size_t)(*counts)[i]; + } + + *out_list = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) + * (*n_out)); + } + + /* TO DO: Find an MPI type that is guaranteed to match SMIOL_Offset */ + /* For now, just return an error if MPI_LONG isn't appropriate */ + if (sizeof(long) != sizeof(SMIOL_Offset)) { + fprintf(stderr, "Error: sizeof(long) != sizeof(SMIOL_Offset)\n"); + return 1; + } + + err = MPI_Gatherv((const void *)in_list, n_in_i, MPI_LONG, + (void *)(*out_list), (*counts), (*displs), MPI_LONG, + root, comm); + if (err != MPI_SUCCESS) { + fprintf(stderr, "Error: MPI_Gatherv failed in aggregate_list\n"); + return 1; + } + + return 0; +} + + +/******************************************************************************* + * + * get_io_elements + * + * Returns a contiguous range of I/O elements for an MPI task + * + * Given the rank of a task, a description of the I/O task arrangement -- + * the number of I/O tasks and the stride between I/O tasks -- as well as the + * total number of elements to read or write, compute the offset of the first + * I/O element as well as the number of elements to read or write for the task. + * + * If this routine is successful in producing a valid io_start and io_count, + * a value of 0 is returned; otherwise, a non-zero value is returned. + * + *******************************************************************************/ +int get_io_elements(int comm_rank, int num_io_tasks, int io_stride, + size_t n_io_elements, size_t *io_start, size_t *io_count) +{ + if (io_start == NULL || io_count == NULL) { + return 1; + } + + *io_start = 0; + *io_count = 0; + + if (comm_rank % io_stride == 0) { + size_t io_rank = (size_t)(comm_rank / io_stride); + size_t elems_per_task = (n_io_elements / (size_t)num_io_tasks); + + if (io_rank >= num_io_tasks) { + return 0; + } + + *io_start = io_rank * elems_per_task; + *io_count = elems_per_task; + + if (io_rank + 1 == (size_t)num_io_tasks) { + size_t remainder = n_io_elements + - (size_t)num_io_tasks * elems_per_task; + *io_count += remainder; + } + } + + return 0; +} + + +/******************************************************************************* + * + * build_exchange + * + * Builds a mapping between compute elements and I/O elements. + * + * Given arrays of global element IDs that each task computes and global element + * IDs that each task reads/writes, this routine works out a mapping of elements + * between compute and I/O tasks. + * + * If all input arguments are determined to be valid and if the routine is + * successful in working out a mapping, the decomp pointer is allocated and + * given valid contents, and SMIOL_SUCCESS is returned; otherwise a non-success + * error code is returned and the decomp pointer is NULL. + * + *******************************************************************************/ +int build_exchange(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + size_t n_io_elements, SMIOL_Offset *io_elements, + struct SMIOL_decomp **decomp) +{ + MPI_Comm comm; + int comm_size; + int comm_rank; + int ierr; + int i, j; + int count; + int nbuf_in, nbuf_out; + SMIOL_Offset *compute_ids; + SMIOL_Offset *io_ids; + SMIOL_Offset *buf_in, *buf_out; + SMIOL_Offset *io_list, *comp_list; + SMIOL_Offset neighbor; + MPI_Request req_in, req_out; + size_t ii; + size_t idx; + size_t n_neighbors; + size_t n_xfer; + size_t n_xfer_total; + size_t n_list; + + const SMIOL_Offset UNKNOWN_TASK = (SMIOL_Offset)(-1); + + + if (context == NULL) { + return SMIOL_INVALID_ARGUMENT; + } + + if (compute_elements == NULL && n_compute_elements != 0) { + return SMIOL_INVALID_ARGUMENT; + } + + if (io_elements == NULL && n_io_elements != 0) { + return SMIOL_INVALID_ARGUMENT; + } + + + comm = MPI_Comm_f2c(context->fcomm); + comm_size = context->comm_size; + comm_rank = context->comm_rank; + + + /* + * Because the count argument to MPI_Isend and MPI_Irecv is an int, at + * most 2^31-1 elements can be transmitted at a time. In this routine, + * arrays of pairs of SMIOL_Offset values will be transmitted as arrays + * of bytes, so n_compute_elements and n_io_elements can be at most + * 2^31-1 / sizeof(SMIOL_Offset) / 2. + */ + i = 0; + if (n_compute_elements > (((size_t)1 << 31) - 1) + / sizeof(SMIOL_Offset) + / (size_t)2) { + i = 1; + } + if (n_io_elements > (((size_t)1 << 31) - 1) + / sizeof(SMIOL_Offset) + / (size_t)2) { + i = 1; + } + + ierr = MPI_Allreduce((const void *)&i, (void *)&j, 1, MPI_INT, MPI_MAX, + comm); + if (j > 0) { + return SMIOL_INVALID_ARGUMENT; + } else if (ierr != MPI_SUCCESS) { + return SMIOL_MPI_ERROR; + } + + + /* + * Allocate an array, compute_ids, with three entries for each compute + * element + * [0] - element global ID + * [1] - element local ID + * [2] - I/O task that reads/writes this element + */ + compute_ids = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * TRIPLET_SIZE + * n_compute_elements); + if (compute_ids == NULL) { + return SMIOL_MALLOC_FAILURE; + } + + /* + * Fill in compute_ids array with global and local IDs; rank of I/O task + * is not yet known + */ + for (ii = 0; ii < n_compute_elements; ii++) { + compute_ids[TRIPLET_SIZE*ii] = compute_elements[ii]; /* global ID */ + compute_ids[TRIPLET_SIZE*ii+1] = (SMIOL_Offset)ii; /* local ID */ + compute_ids[TRIPLET_SIZE*ii+2] = UNKNOWN_TASK; /* I/O task rank */ + } + + /* + * Sort the compute_ids array on global element ID + * (first entry for each element) + */ + sort_triplet_array(n_compute_elements, compute_ids, 0); + + /* + * Allocate buffer with two entries for each I/O element + * [0] - I/O element global ID + * [1] - task that computes this element + */ + nbuf_out = (int)n_io_elements; + buf_out = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * (size_t)2 + * (size_t)nbuf_out); + if (buf_out == NULL) { + free(compute_ids); + return SMIOL_MALLOC_FAILURE; + } + + /* + * Fill buffer with I/O element IDs; compute task is not yet known + */ + for (ii = 0; ii < n_io_elements; ii++) { + buf_out[2*ii] = io_elements[ii]; + buf_out[2*ii+1] = UNKNOWN_TASK; + } + + /* + * Iterate through all ranks in the communicator, receiving from "left" + * neighbor and sending to "right" neighbor in each iteration. + * The objective is to identify, for each I/O element, which MPI rank + * computes that element. At the end of iteration, each rank will have + * seen the I/O element list from all other ranks. + */ + for (i = 0; i < comm_size; i++) { + /* + * Compute the rank whose buffer will be received this iteration + */ + SMIOL_Offset src_rank = (comm_rank - 1 - i + comm_size) + % comm_size; + + /* + * Initiate send of outgoing buffer size and receive of incoming + * buffer size + */ + ierr = MPI_Irecv((void *)&nbuf_in, 1, MPI_INT, + (comm_rank - 1 + comm_size) % comm_size, + (comm_rank + i), comm, &req_in); + + ierr = MPI_Isend((const void *)&nbuf_out, 1, MPI_INT, + (comm_rank + 1) % comm_size, + ((comm_rank + 1) % comm_size + i), comm, + &req_out); + + /* + * Wait until the incoming buffer size has been received + */ + ierr = MPI_Wait(&req_in, MPI_STATUS_IGNORE); + + /* + * Allocate incoming buffer + */ + buf_in = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * (size_t)2 + * (size_t)nbuf_in); + + /* + * Initiate receive of incoming buffer + */ + count = 2 * nbuf_in; + count *= (int)sizeof(SMIOL_Offset); + ierr = MPI_Irecv((void *)buf_in, count, MPI_BYTE, + (comm_rank - 1 + comm_size) % comm_size, + (comm_rank + i), comm, &req_in); + + /* + * Wait until the outgoing buffer size has been sent + */ + ierr = MPI_Wait(&req_out, MPI_STATUS_IGNORE); + + /* + * Initiate send of outgoing buffer + */ + count = 2 * nbuf_out; + count *= (int)sizeof(SMIOL_Offset); + ierr = MPI_Isend((const void *)buf_out, count, MPI_BYTE, + (comm_rank + 1) % comm_size, + ((comm_rank + 1) % comm_size + i), comm, + &req_out); + + /* + * Wait until the incoming buffer has been received + */ + ierr = MPI_Wait(&req_in, MPI_STATUS_IGNORE); + + /* + * Loop through the incoming buffer, marking all elements that + * are computed on this task + */ + for (j = 0; j < nbuf_in; j++) { + /* + * If I/O element does not yet have a computing task... + */ + if (buf_in[2*j+1] == UNKNOWN_TASK) { + SMIOL_Offset *elem; + + /* + * and if this element is computed on this task... + */ + elem = search_triplet_array(buf_in[2*j], + n_compute_elements, + compute_ids, 0); + if (elem != NULL) { + /* + * then mark the element as being + * computed on this task + */ + buf_in[2*j+1] = (SMIOL_Offset)comm_rank; + + /* + * and note locally which task will + * read/write this element + */ + elem[2] = src_rank; + } + } + } + + /* + * Wait until we have sent the outgoing buffer + */ + ierr = MPI_Wait(&req_out, MPI_STATUS_IGNORE); + + /* + * Free outgoing buffer and make the input buffer into + * the output buffer for next iteration + */ + free(buf_out); + buf_out = buf_in; + nbuf_out = nbuf_in; + } + + /* + * The output buffer is now the initial buffer with the compute tasks + * for each I/O element identified + */ + + /* + * Allocate an array, io_ids, with three entries for each I/O element + * [0] - element global ID + * [1] - element local ID + * [2] - compute task that operates on this element + */ + io_ids = (SMIOL_Offset *)malloc(sizeof(SMIOL_Offset) * TRIPLET_SIZE + * n_io_elements); + if (io_ids == NULL) { + free(compute_ids); + free(buf_out); + return SMIOL_MALLOC_FAILURE; + } + + /* + * Fill in io_ids array with global and local IDs, plus the rank of + * the task that computes each element + */ + for (ii = 0; ii < n_io_elements; ii++) { + io_ids[TRIPLET_SIZE*ii] = buf_out[2*ii+0]; /* global ID */ + io_ids[TRIPLET_SIZE*ii+1] = (SMIOL_Offset)ii; /* local ID */ + io_ids[TRIPLET_SIZE*ii+2] = buf_out[2*ii+1]; /* computing task rank */ + } + + free(buf_out); + + /* + * Sort io_ids array on task ID (third entry for each element) + */ + sort_triplet_array(n_io_elements, io_ids, 2); + + *decomp = (struct SMIOL_decomp *)malloc(sizeof(struct SMIOL_decomp)); + if ((*decomp) == NULL) { + free(compute_ids); + free(io_ids); + return SMIOL_MALLOC_FAILURE; + } + + /* + * Initialize the SMIOL_decomp struct + */ + (*decomp)->context = context; + (*decomp)->comp_list = NULL; + (*decomp)->io_list = NULL; + (*decomp)->io_start = 0; + (*decomp)->io_count = 0; + (*decomp)->agg_factor = 1; /* Group with 1 task -> no aggregation */ + (*decomp)->agg_comm = MPI_Comm_c2f(MPI_COMM_NULL); + (*decomp)->n_compute = 0; + (*decomp)->n_compute_agg = 0; + (*decomp)->counts = NULL; + (*decomp)->displs = NULL; + + + /* + * Scan through io_ids to determine number of unique neighbors that + * compute elements read/written on this task, and also determine + * the total number of elements + * computed on other tasks that are read/written on this task + */ + ii = 0; + n_neighbors = 0; + n_xfer_total = 0; + while (ii < n_io_elements) { + /* Task that computes this element */ + neighbor = io_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to read/write for neighbor */ + n_xfer = 0; + + /* + * Since io_ids is sorted on task, as long as task is unchanged, + * increment n_xfer + */ + while (ii < n_io_elements + && io_ids[TRIPLET_SIZE*ii+2] == neighbor) { + n_xfer++; + ii++; + } + if (neighbor != UNKNOWN_TASK) { + n_neighbors++; + n_xfer_total += n_xfer; + } + } + + /* + * Based on number of neighbors and total number of elements to transfer + * allocate the io_list + */ + n_list = sizeof(SMIOL_Offset) * ((size_t)1 + + (size_t)2 * n_neighbors + + n_xfer_total); + (*decomp)->io_list = (SMIOL_Offset *)malloc(n_list); + if ((*decomp)->io_list == NULL) { + free(compute_ids); + free(io_ids); + free(*decomp); + *decomp = NULL; + return SMIOL_MALLOC_FAILURE; + } + io_list = (*decomp)->io_list; + + /* + * Scan through io_ids a second time, filling in the io_list + */ + io_list[0] = (SMIOL_Offset)n_neighbors; + idx = 1; /* Index in io_list where neighbor ID will be written, followed + by number of elements and element local IDs */ + + ii = 0; + while (ii < n_io_elements) { + /* Task that computes this element */ + neighbor = io_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to read/write for neighbor */ + n_xfer = 0; + + /* + * Since io_ids is sorted on task, as long as task is unchanged, + * increment n_xfer + */ + while (ii < n_io_elements + && io_ids[TRIPLET_SIZE*ii+2] == neighbor) { + if (neighbor != UNKNOWN_TASK) { + /* Save local element ID in list */ + io_list[idx+2+n_xfer] = io_ids[TRIPLET_SIZE*ii+1]; + n_xfer++; + } + ii++; + } + if (neighbor != UNKNOWN_TASK) { + io_list[idx] = neighbor; + io_list[idx+1] = (SMIOL_Offset)n_xfer; + idx += (2 + n_xfer); + } + } + + free(io_ids); + + /* + * Sort compute_ids array on task ID (third entry for each element) + */ + sort_triplet_array(n_compute_elements, compute_ids, 2); + + /* + * Scan through compute_ids to determine number of unique neighbors that + * read/write elements computed on this task, and also determine + * the total number of elements read/written on other tasks that are + * computed on this task + */ + ii = 0; + n_neighbors = 0; + n_xfer_total = 0; + while (ii < n_compute_elements) { + /* Task that reads/writes this element */ + neighbor = compute_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to compute for neighbor */ + n_xfer = 0; + + /* + * Since compute_ids is sorted on task, as long as task is + * unchanged, increment n_xfer + */ + while (ii < n_compute_elements + && compute_ids[TRIPLET_SIZE*ii+2] == neighbor) { + n_xfer++; + ii++; + } + if (neighbor != UNKNOWN_TASK) { + n_neighbors++; + n_xfer_total += n_xfer; + } + } + + /* + * Based on number of neighbors and total number of elements to transfer + * allocate the comp_list + */ + n_list = sizeof(SMIOL_Offset) * ((size_t)1 + + (size_t)2 * n_neighbors + + n_xfer_total); + (*decomp)->comp_list = (SMIOL_Offset *)malloc(n_list); + if ((*decomp)->comp_list == NULL) { + free(compute_ids); + free((*decomp)->io_list); + free(*decomp); + *decomp = NULL; + return SMIOL_MALLOC_FAILURE; + } + comp_list = (*decomp)->comp_list; + + /* + * Scan through compute_ids a second time, filling in the comp_list + */ + comp_list[0] = (SMIOL_Offset)n_neighbors; + idx = 1; /* Index in compute_list where neighbor ID will be written, + followed by number of elements and element local IDs */ + + ii = 0; + while (ii < n_compute_elements) { + /* Task that reads/writes this element */ + neighbor = compute_ids[TRIPLET_SIZE*ii + 2]; + + /* Number of elements to compute for neighbor */ + n_xfer = 0; + + /* + * Since compute_ids is sorted on task, as long as task is + * unchanged, increment n_xfer + */ + while (ii < n_compute_elements + && compute_ids[TRIPLET_SIZE*ii+2] == neighbor) { + if (neighbor != UNKNOWN_TASK) { + /* Save local element ID in list */ + comp_list[idx+2+n_xfer] = compute_ids[TRIPLET_SIZE*ii+1]; + n_xfer++; + } + ii++; + } + if (neighbor != UNKNOWN_TASK) { + comp_list[idx] = neighbor; + comp_list[idx+1] = (SMIOL_Offset)n_xfer; + idx += (2 + n_xfer); + } + } + + free(compute_ids); + + return SMIOL_SUCCESS; +} + + +/******************************************************************************* + * + * print_lists + * + * Writes the contents of comp_list and io_list arrays to a text file + * + * Given pointers to the comp_list and io_list arrays from a SMIOL_decomp + * structure, writes the contents of these arrays to a text file in a human- + * readable format. + * + * Because the comp_list and io_list arrays are unique to each MPI task, this + * routine takes as an argument the MPI rank of the calling task. The output + * text file is named list.NNNN.txt, where NNNN is the rank of the task. + * + *******************************************************************************/ +void print_lists(int comm_rank, SMIOL_Offset *comp_list, SMIOL_Offset *io_list) +{ + char filename[14]; + FILE *f; + SMIOL_Offset n_neighbors; + SMIOL_Offset n_elems, neighbor; + int i, j, k; + + snprintf(filename, 14, "list.%4.4i.txt", comm_rank); + + f = fopen(filename, "w"); + + /* + * The lists below are structured as follows: + * list[0] - the number of neighbors for which a task sends/recvs + * | + * list[n] - neighbor task ID | repeated for + * list[n+1] - number of elements, m, to send/recv to/from the neighbor | each neighbor + * list[n+2 .. n+2+m] - local element IDs to send/recv to/from the neighbor | + * | + */ + + fprintf(f, "===== comp_list for MPI rank %i =====\n", comm_rank); + fprintf(f, "Our compute elements are read/written on %i tasks\n", + (int)comp_list[0]); + j = 0; + n_neighbors = comp_list[j++]; + for (i = 0; i < n_neighbors; i++) { + neighbor = comp_list[j++]; + n_elems = comp_list[j++]; + if (neighbor == comm_rank) { + fprintf(f, "----- copy %i elements -----\n", + (int)n_elems); + } else { + fprintf(f, "----- send %i elements to %i -----\n", + (int)n_elems, (int)neighbor); + } + for (k = 0; k < n_elems; k++) { + fprintf(f, " %i\n", (int)comp_list[j+k]); + } + j += n_elems; + } + + fprintf(f, "\n\n"); + fprintf(f, "===== io_list for MPI rank %i =====\n", comm_rank); + fprintf(f, "Our I/O elements are computed on %i tasks\n", + (int)io_list[0]); + j = 0; + n_neighbors = io_list[j++]; + for (i = 0; i < n_neighbors; i++) { + neighbor = io_list[j++]; + n_elems = io_list[j++]; + if (neighbor == comm_rank) { + fprintf(f, "----- copy %i elements -----\n", + (int)n_elems); + } else { + fprintf(f, "----- recv %i elements from %i -----\n", + (int)n_elems, (int)neighbor); + } + for (k = 0; k < n_elems; k++) { + fprintf(f, " %i\n", (int)io_list[j+k]); + } + j += n_elems; + } + fprintf(f, "\n\n"); + + + fprintf(f, "SMIOL_Offset comp_list_correct[] = { "); + j = 0; + n_neighbors = comp_list[j++]; + fprintf(f, "%i", (int)n_neighbors); + + for (i = 0; i < n_neighbors; i++) { + neighbor = comp_list[j++]; + fprintf(f, ", %i", (int)neighbor); + + n_elems = comp_list[j++]; + fprintf(f, ", %i", (int)n_elems); + + for (k = 0; k < n_elems; k++) { + fprintf(f, ", %i", (int)comp_list[j+k]); + } + j += n_elems; + } + fprintf(f, " };\n"); + + fprintf(f, "SMIOL_Offset io_list_correct[] = { "); + j = 0; + n_neighbors = io_list[j++]; + fprintf(f, "%i", (int)n_neighbors); + + for (i = 0; i < n_neighbors; i++) { + neighbor = io_list[j++]; + fprintf(f, ", %i", (int)neighbor); + + n_elems = io_list[j++]; + fprintf(f, ", %i", (int)n_elems); + + for (k = 0; k < n_elems; k++) { + fprintf(f, ", %i", (int)io_list[j+k]); + } + j += n_elems; + } + fprintf(f, " };\n"); + + fclose(f); +} + + +/******************************************************************************* + * + * comp_sort_0 + * + * Compares two SMIOL_Offset triplets based on their first entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_sort_0(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); +} + + +/******************************************************************************* + * + * comp_sort_1 + * + * Compares two SMIOL_Offset triplets based on their second entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + * If the triplets a and b have equal values in their second entry, the values + * in their first entry will be used to determine the result of the comparison. + * + *******************************************************************************/ +static int comp_sort_1(const void *a, const void *b) +{ + int res; + + res = (((const SMIOL_Offset *)a)[1] > ((const SMIOL_Offset *)b)[1]) + - (((const SMIOL_Offset *)a)[1] < ((const SMIOL_Offset *)b)[1]); + if (res == 0) { + res = (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); + } + return res; +} + + +/******************************************************************************* + * + * comp_sort_2 + * + * Compares two SMIOL_Offset triplets based on their third entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + * If the triplets a and b have equal values in their third entry, the values + * in their first entry will be used to determine the result of the comparison. + * + *******************************************************************************/ +static int comp_sort_2(const void *a, const void *b) +{ + int res; + + res = (((const SMIOL_Offset *)a)[2] > ((const SMIOL_Offset *)b)[2]) + - (((const SMIOL_Offset *)a)[2] < ((const SMIOL_Offset *)b)[2]); + if (res == 0) { + res = (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); + } + return res; +} + + +/******************************************************************************* + * + * comp_search_0 + * + * Compares two SMIOL_Offset triplets based on their first entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_search_0(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[0] > ((const SMIOL_Offset *)b)[0]) + - (((const SMIOL_Offset *)a)[0] < ((const SMIOL_Offset *)b)[0]); +} + + +/******************************************************************************* + * + * comp_search_1 + * + * Compares two SMIOL_Offset triplets based on their second entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_search_1(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[1] > ((const SMIOL_Offset *)b)[1]) + - (((const SMIOL_Offset *)a)[1] < ((const SMIOL_Offset *)b)[1]); +} + + +/******************************************************************************* + * + * comp_search_2 + * + * Compares two SMIOL_Offset triplets based on their third entry, returning: + * 1 if the first is larger than the second, + * 0 if the two are equal, and + * -1 if the first is less than the second. + * + *******************************************************************************/ +static int comp_search_2(const void *a, const void *b) +{ + return (((const SMIOL_Offset *)a)[2] > ((const SMIOL_Offset *)b)[2]) + - (((const SMIOL_Offset *)a)[2] < ((const SMIOL_Offset *)b)[2]); +} diff --git a/src/external/SMIOL/smiol_utils.h b/src/external/SMIOL/smiol_utils.h new file mode 100644 index 0000000000..6cdc2e7687 --- /dev/null +++ b/src/external/SMIOL/smiol_utils.h @@ -0,0 +1,47 @@ +/******************************************************************************* + * Utilities and helper functions for SMIOL + *******************************************************************************/ +#ifndef SMIOL_UTILS_H +#define SMIOL_UTILS_H + +#include "smiol_types.h" + +#define SMIOL_COMP_TO_IO 1 +#define SMIOL_IO_TO_COMP 2 + + +/* + * Searching and sorting + */ +void sort_triplet_array(size_t n_arr, SMIOL_Offset *arr, int sort_entry); +SMIOL_Offset *search_triplet_array(SMIOL_Offset key, + size_t n_arr, SMIOL_Offset *arr, + int search_entry); + +/* + * Communication + */ +int transfer_field(const struct SMIOL_decomp *decomp, int dir, + size_t element_size, const void *in_field, void *out_field); + +int aggregate_list(MPI_Comm comm, int root, size_t n_in, SMIOL_Offset *in_list, + size_t *n_out, SMIOL_Offset **out_list, + int **counts, int **displs); + +/* + * Field decomposition + */ +int get_io_elements(int comm_rank, int num_io_tasks, int io_stride, + size_t n_io_elements, size_t *io_start, size_t *io_count); + +int build_exchange(struct SMIOL_context *context, + size_t n_compute_elements, SMIOL_Offset *compute_elements, + size_t n_io_elements, SMIOL_Offset *io_elements, + struct SMIOL_decomp **decomp); + +/* + * Debugging + */ +void print_lists(int comm_rank, SMIOL_Offset *comp_list, SMIOL_Offset *io_list); + +#endif diff --git a/src/external/SMIOL/smiolf.F90 b/src/external/SMIOL/smiolf.F90 new file mode 100644 index 0000000000..bf001c848a --- /dev/null +++ b/src/external/SMIOL/smiolf.F90 @@ -0,0 +1,2057 @@ +#include "smiol_codes.inc" + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! SMIOL -- The Simple MPAS I/O Library +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module SMIOLf + + use iso_c_binding, only : c_int, c_size_t, c_int64_t, c_ptr + + private + + public :: SMIOLf_context, & + SMIOLf_decomp, & + SMIOLf_file + + public :: SMIOL_offset_kind + + public :: SMIOLf_init, & + SMIOLf_finalize, & + SMIOLf_inquire, & + SMIOLf_open_file, & + SMIOLf_close_file, & + SMIOLf_define_dim, & + SMIOLf_inquire_dim, & + SMIOLf_define_var, & + SMIOLf_inquire_var, & + SMIOLf_put_var, & + SMIOLf_get_var, & + SMIOLf_define_att, & + SMIOLf_inquire_att, & + SMIOLf_sync_file, & + SMIOLf_error_string, & + SMIOLf_lib_error_string, & + SMIOLf_set_option, & + SMIOLf_create_decomp, & + SMIOLf_free_decomp, & + SMIOLf_set_frame, & + SMIOLf_get_frame, & + SMIOLf_f_to_c_string + + + integer, parameter :: SMIOL_offset_kind = c_int64_t ! Must match SMIOL_Offset in smiol_types.h + + + type, bind(C) :: SMIOLf_context + integer :: fcomm ! Fortran handle to MPI communicator; MPI_Fint on the C side, which is supposed to match + ! a Fortran integer + + integer(c_int) :: comm_size ! Size of MPI communicator + integer(c_int) :: comm_rank ! Rank within MPI communicator + + integer(c_int) :: num_io_tasks ! The number of I/O tasks + integer(c_int) :: io_stride ! The stride between I/O tasks in the communicator + + integer(c_int) :: lib_ierr ! Library-specific error code + integer(c_int) :: lib_type ! From which library the error code originated + end type SMIOLf_context + + type, bind(C) :: SMIOLf_file + type (c_ptr) :: context ! Pointer to (struct SMIOL_context); the context within which the file was opened + integer(kind=SMIOL_offset_kind) :: frame ! Current frame of the file +#ifdef SMIOL_PNETCDF + integer(c_int) :: state ! parallel-netCDF file state (i.e. Define or data mode) + integer(c_int) :: ncidp ! parallel-netCDF file handle + integer(c_size_t) :: bufsize ! Size of buffer attached to this file + integer(c_int) :: n_reqs ! Number of pending non-blocking requests + type (c_ptr) :: reqs ! Array of pending non-blocking request handles +#endif + integer(c_int) :: io_task ! 1 = this task performs I/O calls; 0 = no I/O calls on this task + integer :: io_file_comm ! Communicator shared by all tasks with io_task == 1 + integer :: io_group_comm ! Communicator shared by tasks associated with an I/O task, usually 1 I/O task + ! and N-1 non-I/O tasks, where N is the I/O stride + end type SMIOLf_file + + type, bind(C) :: SMIOLf_decomp + ! + ! The lists below are structured (in C) as follows: + ! list[0] - the number of neighbors for which a task sends/recvs + ! | + ! list[n] - neighbor task ID | repeated for + ! list[n+1] - number of elements, m, to send/recv to/from the neighbor | each neighbor + ! list[n+2 .. n+2+m] - local element IDs to send/recv to/from the neighbor | + ! | + ! + type(c_ptr) :: comp_list ! Elements to be sent/received from/on a compute task + type(c_ptr) :: io_list ! Elements to be send/received from/on an I/O task + + type (c_ptr) :: context ! Pointer to (struct SMIOL_context); the context for this decomp + + integer(c_size_t) :: io_start; ! The starting offset on disk for I/O by a task + integer(c_size_t) :: io_count; ! The number of elements for I/O by a task + + integer(c_int) :: agg_factor ! Aggregation factor, or size of aggregation group + integer :: agg_comm ! Communicator for aggregation/deaggregation operations + integer(c_size_t) :: n_compute ! Number of un-aggregated compute elements on the task + integer(c_size_t) :: n_compute_agg ! Number of aggregated compute elements on the task + type (c_ptr) :: counts ! Compute element counts for tasks in aggregation group + type (c_ptr) :: displs ! Displacements in aggregated list of elements for tasks + ! in aggregation group + end type SMIOLf_decomp + + interface SMIOLf_define_att + module procedure SMIOLf_define_att_int + module procedure SMIOLf_define_att_float + module procedure SMIOLf_define_att_double + module procedure SMIOLf_define_att_text + end interface + + interface SMIOLf_inquire_att + module procedure SMIOLf_inquire_att_int + module procedure SMIOLf_inquire_att_float + module procedure SMIOLf_inquire_att_double + module procedure SMIOLf_inquire_att_text + end interface + + ! + ! Note: The implementations of the specific SMIOLf_put_var routines + ! are found in the file smiolf_put_get_var.inc, which is included + ! in this module with a pre-processor directive + ! + interface SMIOLf_put_var + module procedure SMIOLf_put_var_0d_char + module procedure SMIOLf_put_var_0d_int32 + module procedure SMIOLf_put_var_0d_real32 + module procedure SMIOLf_put_var_0d_real64 + module procedure SMIOLf_put_var_1d_int32 + module procedure SMIOLf_put_var_1d_real32 + module procedure SMIOLf_put_var_1d_real64 + module procedure SMIOLf_put_var_2d_int32 + module procedure SMIOLf_put_var_2d_real32 + module procedure SMIOLf_put_var_2d_real64 + module procedure SMIOLf_put_var_3d_int32 + module procedure SMIOLf_put_var_3d_real32 + module procedure SMIOLf_put_var_3d_real64 + module procedure SMIOLf_put_var_4d_int32 + module procedure SMIOLf_put_var_4d_real32 + module procedure SMIOLf_put_var_4d_real64 + module procedure SMIOLf_put_var_5d_real32 + module procedure SMIOLf_put_var_5d_real64 + end interface SMIOLf_put_var + + ! + ! Note: The implementations of the specific SMIOLf_get_var routines + ! are found in the file smiolf_put_get_var.inc, which is included + ! in this module with a pre-processor directive + ! + interface SMIOLf_get_var + module procedure SMIOLf_get_var_0d_char + module procedure SMIOLf_get_var_0d_int32 + module procedure SMIOLf_get_var_0d_real32 + module procedure SMIOLf_get_var_0d_real64 + module procedure SMIOLf_get_var_1d_int32 + module procedure SMIOLf_get_var_1d_real32 + module procedure SMIOLf_get_var_1d_real64 + module procedure SMIOLf_get_var_2d_int32 + module procedure SMIOLf_get_var_2d_real32 + module procedure SMIOLf_get_var_2d_real64 + module procedure SMIOLf_get_var_3d_int32 + module procedure SMIOLf_get_var_3d_real32 + module procedure SMIOLf_get_var_3d_real64 + module procedure SMIOLf_get_var_4d_int32 + module procedure SMIOLf_get_var_4d_real32 + module procedure SMIOLf_get_var_4d_real64 + module procedure SMIOLf_get_var_5d_real32 + module procedure SMIOLf_get_var_5d_real64 + end interface SMIOLf_get_var + + ! C interface definitions used in multiple routines + interface + function SMIOL_define_att(file, varname, att_name, att_type, att) result(ierr) bind(C, name='SMIOL_define_att') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + type (c_ptr), value :: varname + character(kind=c_char), dimension(*) :: att_name + integer(kind=c_int), value :: att_type + type (c_ptr), value :: att + integer(kind=c_int) :: ierr + end function + + function SMIOL_inquire_att(file, varname, att_name, att_type, att_len, att) result(ierr) bind(C, name='SMIOL_inquire_att') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + type (c_ptr), value :: varname + character(kind=c_char), dimension(*) :: att_name + type (c_ptr), value :: att_type + type (c_ptr), value :: att_len + type (c_ptr), value :: att + integer(kind=c_int) :: ierr + end function + + function SMIOL_put_var(file, varname, decomp, buf) result(ierr) bind(C, name='SMIOL_put_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character (kind=c_char), dimension(*) :: varname + type (c_ptr), value :: decomp + type (c_ptr), value :: buf + integer (kind=c_int) :: ierr + end function + + function SMIOL_get_var(file, varname, decomp, buf) result(ierr) bind(C, name='SMIOL_get_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character (kind=c_char), dimension(*) :: varname + type (c_ptr), value :: decomp + type (c_ptr), value :: buf + integer (kind=c_int) :: ierr + end function + end interface + + +contains + + + ! + ! Library methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_init + ! + !> \brief Initialize a SMIOL context + !> \details + !> Initializes a SMIOL context, within which decompositions may be defined and + !> files may be read and written. The input argument comm is an MPI communicator, + !> and the input arguments num_io_tasks and io_stride provide the total number + !> of I/O tasks and the stride between those I/O tasks within the communicator. + !> + !> Upon successful return the context argument points to a valid SMIOL context; + !> otherwise, it is NULL and an error code other than MPI_SUCCESS is returned. + !> + !> Note: It is assumed that MPI_Init has been called prior to this routine, so + !> that any use of the provided MPI communicator will be valid. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_init(comm, num_io_tasks, io_stride, context) result(ierr) + + use iso_c_binding, only : c_ptr, c_f_pointer, c_null_ptr, c_associated + + implicit none + + integer, intent(in) :: comm + integer, intent(in) :: num_io_tasks + integer, intent(in) :: io_stride + type (SMIOLf_context), pointer :: context + + type (c_ptr) :: c_context = c_null_ptr + + ! C interface definitions + interface + function SMIOL_fortran_init(comm, num_io_tasks, io_stride, context) result(ierr) bind(C, name='SMIOL_fortran_init') + use iso_c_binding, only : c_int, c_ptr + integer, value :: comm ! MPI_Fint on the C side, which is supposed to match a Fortran integer + integer(c_int), value :: num_io_tasks + integer(c_int), value :: io_stride + type (c_ptr) :: context + integer(kind=c_int) :: ierr + end function + end interface + + ierr = SMIOL_fortran_init(comm, num_io_tasks, io_stride, c_context) + + if (ierr == SMIOL_SUCCESS) then + if (.not. c_associated(c_context)) then + nullify(context) + ierr = SMIOL_FORTRAN_ERROR + else + call c_f_pointer(c_context, context) + end if + else + if (.not. c_associated(c_context)) then + nullify(context) + else + ierr = SMIOL_FORTRAN_ERROR + end if + end if + + end function SMIOLf_init + + + !----------------------------------------------------------------------- + ! routine SMIOLf_finalize + ! + !> \brief Finalize a SMIOL context + !> \details + !> Finalizes a SMIOL context and frees all memory in the SMIOL_context instance. + !> After this routine is called, no other SMIOL routines that make reference to + !> the finalized context should be called. + !> + !> Upon return, the context argument will be unassociated if no errors occurred. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_finalize(context) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc, c_associated, c_null_ptr + + implicit none + + type (SMIOLf_context), pointer :: context + + type (c_ptr) :: c_context = c_null_ptr + + ! C interface definitions + interface + function SMIOL_finalize(context) result(ierr) bind(C, name='SMIOL_finalize') + use iso_c_binding, only : c_int, c_ptr + type (c_ptr) :: context + integer(kind=c_int) :: ierr + end function + end interface + + if (associated(context)) then + c_context = c_loc(context) + end if + + ierr = SMIOL_finalize(c_context) + + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_context)) then + ierr = SMIOL_FORTRAN_ERROR + else + nullify(context) + end if + else + if (.not. c_associated(c_context)) then + nullify(context) + end if + end if + + end function SMIOLf_finalize + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire + ! + !> \brief Inquire about a SMIOL context + !> \details + !> Detailed description of what this routine does. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire() result(ierr) + + implicit none + + ierr = 0 + + end function SMIOLf_inquire + + + ! + ! File methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_open_file + ! + !> \brief Opens a file within a SMIOL context + !> \details + !> Depending on the specified file mode, creates or opens the file specified + !> by filename within the provided SMIOL context. + !> + !> The optional bufsize argument specifies the size in bytes of the buffer + !> to be attached to the file by I/O tasks; at present this buffer is only + !> used by the Parallel-NetCDF library if the file is opened with a mode of + !> SMIOL_FILE_CREATE or SMIOL_FILE_WRITE. A bufsize of 0 will force the use of + !> the Parallel-NetCDF blocking write interface, while a nonzero value enables + !> the use of the non-blocking, buffered interface for writing. If the bufsize + !> argument is not present, a default buffer size of 128 MiB is used. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned, and the file handle argument + !> will point to a valid file handle. Otherwise, the file handle is not associated + !> and an error code other than SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_open_file(context, filename, mode, file, bufsize) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr, c_null_ptr, c_char, c_size_t, c_associated, c_f_pointer + + implicit none + + type (SMIOLf_context), pointer :: context + character(len=*), intent(in) :: filename + integer, intent(in) :: mode + type (SMIOLf_file), pointer :: file + integer(kind=c_size_t), intent(in), optional :: bufsize + + ! Default buffer size to use if optional bufsize argument is not provided + integer (kind=c_size_t), parameter :: default_bufsize = int(128*1024*1024, kind=c_size_t) + + type (c_ptr) :: c_context = c_null_ptr + type (c_ptr) :: c_file = c_null_ptr + integer(kind=c_int) :: c_mode + character(kind=c_char), dimension(:), pointer :: c_filename + + ! C interface definitions + interface + function SMIOL_open_file(context, filename, mode, file, bufsize) result(ierr) bind(C, name='SMIOL_open_file') + use iso_c_binding, only : c_char, c_ptr, c_int, c_size_t + type (c_ptr), value :: context + character(kind=c_char), dimension(*) :: filename + integer(kind=c_int), value :: mode + type (c_ptr) :: file + integer(kind=c_size_t), value :: bufsize + integer(kind=c_int) :: ierr + end function + end interface + + if (associated(context)) then + c_context = c_loc(context) + end if + + ! + ! Convert Fortran string to C character array + ! + allocate(c_filename(len_trim(filename) + 1)) + call SMIOLf_f_to_c_string(filename, c_filename) + + c_mode = mode + + if (present(bufsize)) then + ierr = SMIOL_open_file(c_context, c_filename, c_mode, c_file, & + bufsize) + else + ierr = SMIOL_open_file(c_context, c_filename, c_mode, c_file, & + default_bufsize) + end if + + deallocate(c_filename) + + if (ierr == SMIOL_SUCCESS) then + if (.not. c_associated(c_file)) then + nullify(file) + ierr = SMIOL_FORTRAN_ERROR + else + call c_f_pointer(c_file, file) + end if + else + if (.not. c_associated(c_file)) then + nullify(file) + else + ierr = SMIOL_FORTRAN_ERROR + end if + end if + + end function SMIOLf_open_file + + + !----------------------------------------------------------------------- + ! routine SMIOLf_close_file + ! + !> \brief Closes a file within a SMIOL context + !> \details + !> Closes the file associated with the provided file handle. Upon successful + !> completion, SMIOL_SUCCESS is returned, the file will be closed, and all memory + !> that is uniquely associated with the file handle will be deallocated. + !> Otherwise, an error code other than SMIOL_SUCCESS will be returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_close_file(file) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr, c_null_ptr, c_associated + + implicit none + + type (SMIOLf_file), pointer :: file + + type (c_ptr) :: c_file = c_null_ptr + + ! C interface definitions + interface + function SMIOL_close_file(file) result(ierr) bind(C, name='SMIOL_close_file') + use iso_c_binding, only : c_ptr, c_int + type (c_ptr) :: file + integer(kind=c_int) :: ierr + end function + end interface + + if (associated(file)) then + c_file = c_loc(file) + end if + + ierr = SMIOL_close_file(c_file) + + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_file)) then + ierr = SMIOL_FORTRAN_ERROR + else + nullify(file) + end if + else + if (.not. c_associated(c_file)) then + nullify(file) + end if + end if + + end function SMIOLf_close_file + + + ! + ! Dimension methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_dim + ! + !> \brief Defines a new dimension in a file + !> \details + !> Defines a dimension with the specified name and size in the file associated + !> with the file handle. If a negative value is provided for the size argument, + !> the dimension will be defined as an unlimited or record dimension. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + !> code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_dim(file, dimname, dimsize) result(ierr) + + use iso_c_binding, only : c_char, c_loc, c_ptr + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: dimname + integer(kind=SMIOL_offset_kind), intent(in) :: dimsize + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_dimname + + ! C interface definitions + interface + function SMIOL_define_dim(file, dimname, dimsize) result(ierr) bind(C, name='SMIOL_define_dim') + use iso_c_binding, only : c_ptr, c_char, c_int + import SMIOL_offset_kind + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: dimname + integer(kind=SMIOL_offset_kind), value :: dimsize + integer(kind=c_int) :: ierr + end function + end interface + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + allocate(c_dimname(len_trim(dimname) + 1)) + call SMIOLf_f_to_c_string(dimname, c_dimname) + + ierr = SMIOL_define_dim(c_file, c_dimname, dimsize) + + deallocate(c_dimname) + + end function SMIOLf_define_dim + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_dim + ! + !> \brief Inquires about an existing dimension in a file + !> \details + !> Inquire about an existing dimension's size or if a dimension is the + !> unlimited dimension or not. If dimsize is present, the size of the dimension + !> will be returned in it; likewise, if is_unlimited is present, is_unlimited + !> will return either .true. or .false. depending on whether or not the dimension + !> is the unlimited dimension or not. + !> + !> For unlimited dimensions, the current size of the dimension is returned; + !> future writes of additional records to a file can lead to different return + !> sizes for unlimited dimensions. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + !> code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_dim(file, dimname, dimsize, is_unlimited) result(ierr) + + use iso_c_binding, only : c_char, c_loc, c_ptr, c_null_ptr + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: dimname + integer(kind=SMIOL_offset_kind), intent(out), optional :: dimsize + logical, intent(out), optional :: is_unlimited + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_dimname + integer (kind=SMIOL_offset_kind), target :: c_dimsize + integer (kind=c_int), target :: c_is_unlimited + type (c_ptr) :: c_dimsize_ptr + type (c_ptr) :: c_is_unlimited_ptr + + + ! C interface definitions + interface + function SMIOL_inquire_dim(file, dimname, dimsize, is_unlimited) result(ierr) bind(C, name='SMIOL_inquire_dim') + use iso_c_binding, only : c_ptr, c_char, c_int + import SMIOL_offset_kind + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: dimname + type (c_ptr), value :: dimsize + type (c_ptr), value :: is_unlimited + integer(kind=c_int) :: ierr + end function + end interface + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + allocate(c_dimname(len_trim(dimname) + 1)) + call SMIOLf_f_to_c_string(dimname, c_dimname) + + ! + ! Set C dimsize + ! + if (present(dimsize)) then + c_dimsize_ptr = c_loc(c_dimsize) + else + c_dimsize_ptr = c_null_ptr + endif + + ! + ! Set C pointer for unlimited dimension inquiry argument + ! + if (present(is_unlimited)) then + c_is_unlimited_ptr = c_loc(c_is_unlimited) + else + c_is_unlimited_ptr = c_null_ptr + end if + + ierr = SMIOL_inquire_dim(c_file, c_dimname, c_dimsize_ptr, c_is_unlimited_ptr) + + if (present(dimsize)) then + dimsize = c_dimsize + end if + + if (present(is_unlimited)) then + if (c_is_unlimited == 1) then + is_unlimited = .true. + else + is_unlimited = .false. + end if + end if + + deallocate(c_dimname) + + end function SMIOLf_inquire_dim + + + ! + ! Variable methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_var + ! + !> \brief Defines a new variable in a file + !> \details + !> Defines a variable with the specified name, type, and dimensions in an open + !> file pointed to by the file argument. The varname and dimnames arguments + !> are expected to be null-terminated strings, except if the variable has + !> zero dimensions, in which case the dimnames argument is ignored. + !> + !> Unlike the C SMIOL_define_var function, this routine assumes that + !> dimnames provides the dimension names in their natural Fortran order, + !> with the fastest-varying dimension given first and any unlimited + !> dimension given last. + !> + !> Upon successful completion, SMIOL_SUCCESS is returned; otherwise, an error + !> code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_var(file, varname, vartype, ndims, dimnames) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_null_char, c_ptr, c_loc, c_null_ptr + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + integer, intent(in) :: vartype + integer, intent(in) :: ndims + character(len=*), dimension(:), intent(in) :: dimnames + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_varname + integer(kind=c_int) :: c_vartype + integer(kind=c_int) :: c_ndims + + type (c_ptr) :: c_dimnames_ptr + type (c_ptr), dimension(:), allocatable, target :: c_dimnames + + integer :: i, j + + ! C interface definitions + interface + function SMIOL_define_var(file, varname, vartype, ndims, dimnames) result(ierr) bind(C, name='SMIOL_define_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: varname + integer(kind=c_int), value :: vartype + integer(kind=c_int), value :: ndims + type (c_ptr), value :: dimnames + integer(kind=c_int) :: ierr + end function + end interface + + ! Used to store an array of pointers to character arrays + type string_ptr + character(kind=c_char), dimension(:), allocatable :: str + end type string_ptr + + type (string_ptr), dimension(:), allocatable, target :: strings + + ! + ! Check that the 'dimnames' array has at least ndims elements + ! + if (size(dimnames) < ndims) then + ierr = SMIOL_FORTRAN_ERROR + return + end if + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + allocate(c_varname(len_trim(varname) + 1)) + call SMIOLf_f_to_c_string(varname, c_varname) + + ! + ! Convert vartype and ndims + ! + c_vartype = vartype + c_ndims = ndims + + ! + ! Convert dimnames, reversing their order + ! + allocate(c_dimnames(ndims)) + allocate(strings(ndims)) + + do j=1,ndims + allocate(strings(j) % str(len_trim(dimnames(ndims-j+1))+1)) + + do i=1,len_trim(dimnames(ndims-j+1)) + strings(j) % str(i) = dimnames(ndims-j+1)(i:i) + end do + strings(j) % str(i) = c_null_char + c_dimnames(j) = c_loc(strings(j) % str) + end do + + if (ndims > 0) then + c_dimnames_ptr = c_loc(c_dimnames) + else + c_dimnames_ptr = c_null_ptr + end if + + ierr = SMIOL_define_var(c_file, c_varname, c_vartype, c_ndims, c_dimnames_ptr) + + do j=1,ndims + deallocate(strings(j) % str) + end do + + deallocate(c_varname) + deallocate(strings) + deallocate(c_dimnames) + + end function SMIOLf_define_var + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_var + ! + !> \brief Inquires about an existing variable in a file + !> \details + !> Inquires about a variable in a file, and optionally returns the type + !> of the variable, the dimensionality of the variable, and the names of + !> the dimensions of the variable. + !> + !> If the names of a variable's dimensions are requested (by providing an + !> actual argument for dimnames), the size of the dimnames array must be at + !> least the number of dimensions in the variable, and each character string + !> in the dimnames array must be large enough to accommodate the corresponding + !> dimension name. + !> + !> Unlike the C SMIOL_inquire_var function, this routine returns the list of + !> dimension names in its natural Fortran order, with the fastest-varying + !> dimension given first and any unlimited dimension given last. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_var(file, varname, vartype, ndims, dimnames) result(ierr) + + use iso_c_binding, only : c_char, c_null_char, c_loc, c_ptr, c_null_ptr, c_int + + implicit none + + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + integer, intent(out), optional :: vartype + integer, intent(out), optional :: ndims + character(len=*), dimension(:), intent(out), optional :: dimnames + + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), pointer :: c_varname + integer(kind=c_int), target :: c_vartype + integer(kind=c_int), target :: c_ndims + type (c_ptr), dimension(:), allocatable, target :: c_dimnames + + type (c_ptr) :: c_vartype_ptr + type (c_ptr) :: c_ndims_ptr + type (c_ptr) :: c_dimnames_ptr + + integer :: i, j, ndims_in + + ! C interface definitions + interface + function SMIOL_inquire_var(file, varname, vartype, ndims, dimnames) result(ierr) bind(C, name='SMIOL_inquire_var') + use iso_c_binding, only : c_ptr, c_char, c_int + type (c_ptr), value :: file + character(kind=c_char), dimension(*) :: varname + type (c_ptr), value :: vartype + type (c_ptr), value :: ndims + type (c_ptr), value :: dimnames + integer(kind=c_int) :: ierr + end function + end interface + + ! Used to store an array of pointers to character arrays + type string_ptr + character(kind=c_char), dimension(:), allocatable :: str + end type string_ptr + + type (string_ptr), dimension(:), allocatable, target :: strings + + + ! Get C address of file; there is no need to worry about an unassociated file here, + ! since the file argument is not a pointer + c_file = c_loc(file) + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + call SMIOLf_f_to_c_string(varname, c_varname) + + ! + ! Set C pointer for variable type + ! + if (present(vartype)) then + c_vartype_ptr = c_loc(c_vartype) + else + c_vartype_ptr = c_null_ptr + end if + + ! + ! Set C pointer for number of dimensions + ! This is done even if dimnames is requested but ndims is not, + ! since c_ndims may be used later on when copying out strings + ! to dimnames. + ! + if (present(ndims) .or. present(dimnames)) then + c_ndims_ptr = c_loc(c_ndims) + else + c_ndims_ptr = c_null_ptr + end if + + ! + ! Set C pointers for dimension names in C order + ! + if (present(dimnames)) then + ndims_in = size(dimnames) + allocate(c_dimnames(ndims_in)) + allocate(strings(ndims_in)) + + do j=1,ndims_in + allocate(strings(j) % str(len(dimnames(ndims_in-j+1))+1)) + c_dimnames(j) = c_loc(strings(j) % str) + end do + c_dimnames_ptr = c_loc(c_dimnames) + else + c_dimnames_ptr = c_null_ptr + end if + + + ierr = SMIOL_inquire_var(c_file, c_varname, c_vartype_ptr, c_ndims_ptr, c_dimnames_ptr) + + deallocate(c_varname) + + if (ierr /= SMIOL_SUCCESS) then + return + end if + + ! + ! Copy variable type to output argument + ! + if (present(vartype)) then + vartype = c_vartype + end if + + ! + ! Copy number of dimensions to output argument + ! + if (present(ndims)) then + ndims = c_ndims + end if + + ! + ! Copy dimension names to output argument, reversing their order + ! + if (present(dimnames)) then + do j=1,c_ndims + do i=1,len(dimnames(c_ndims-j+1)) + if (strings(j) % str(i) == c_null_char) exit + end do + + i = i - 1 + + dimnames(c_ndims-j+1)(1:i) = transfer(strings(j) % str(1:i), dimnames(c_ndims-j+1)) + dimnames(c_ndims-j+1) = dimnames(c_ndims-j+1)(1:i) + end do + + do j=1,ndims_in + deallocate(strings(j) % str) + end do + deallocate(strings) + deallocate(c_dimnames) + end if + + end function SMIOLf_inquire_var + + +#include "smiolf_put_get_var.inc" + + + ! + ! Attribute methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_int + ! + !> \brief Defines a new integer attribute + !> \details + !> Defines a new integer attribute for a variable if varname is not + !> an empty string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_int(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_int, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + integer(kind=c_int), intent(in), target :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + att_ptr = c_loc(att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_INT32, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_define_att_int + + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_float + ! + !> \brief Defines a new float attribute + !> \details + !> Defines a new float attribute for a variable if varname is not an empty + !> string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_float(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_float, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_float), intent(in), target :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + att_ptr = c_loc(att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_REAL32, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_define_att_float + + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_double + ! + !> \brief Defines a new double attribute + !> \details + !> Defines a new double attribute for a variable if varname is not an empty + !> string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_double(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_double, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_double), intent(in), target :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + att_ptr = c_loc(att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_REAL64, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_define_att_double + + + !----------------------------------------------------------------------- + ! routine SMIOLf_define_att_text + ! + !> \brief Defines a new text attribute + !> \details + !> Defines a new text attribute for a variable if varname is not an empty + !> string, or a global attribute otherwise. + !> + !> If the attribute has been successfully defined for the variable or file, + !> SMIOL_SUCCESS is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_define_att_text(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + character(len=*), intent(in) :: att + + ! Local variables + integer :: i + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + character(kind=c_char), dimension(:), allocatable, target :: c_att + type (c_ptr) :: att_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + allocate(c_att(len_trim(att) + 1)) + do i=1,len_trim(att) + c_att(i) = att(i:i) + end do + c_att(i) = c_null_char + + att_ptr = c_loc(c_att) + + ierr = SMIOL_define_att(c_file, c_varname_ptr, c_att_name, SMIOL_CHAR, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + deallocate(c_att) + + end function SMIOLf_define_att_text + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_int + ! + !> \brief Inquires about an integer attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, and if it is integer-valued, then + !> SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not an integer + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_int(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_int, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + integer(kind=c_int), intent(out), target :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, c_null_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_INT32) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + att_ptr = c_loc(att) + + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_inquire_att_int + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_float + ! + !> \brief Inquires about a float attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, and if it is float-valued, then + !> SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not a float + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_float(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_float, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_float), intent(out), target :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, c_null_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_REAL32) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + att_ptr = c_loc(att) + + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_inquire_att_float + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_double + ! + !> \brief Inquires about a double attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, and if it is double-valued, then + !> SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not a double + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_double(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_double, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + real(kind=c_double), intent(out), target :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, c_null_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_REAL64) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + att_ptr = c_loc(att) + + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + + end function SMIOLf_inquire_att_double + + + !----------------------------------------------------------------------- + ! routine SMIOLf_inquire_att_text + ! + !> \brief Inquires about a text attribute + !> \details + !> Inquires about a variable attribute if varname is not an empty string, + !> or a global attribute otherwise. + !> + !> If the requested attribute is found, if it is character-valued, and if + !> the att output argument is long enough to contain the attribute value, + !> then SMIOL_SUCCESS is returned and the att output argument will contain + !> the attribute value. If the attribute was found, but it is not a character + !> attribute, SMIOL_WRONG_ARG_TYPE is returned, and the contents of att are + !> undefined. If the attribute was found, and it is a character attribute, + !> but the att output argument is not long enough to contain the attribute + !> value, then SMIOL_INSUFFICIENT_ARG is returned, and the contents of att + !> are undefined. + !> + !> If SMIOL was not compiled with support for any file library, this routine + !> will always return SMIOL_WRONG_ARG_TYPE. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_inquire_att_text(file, varname, att_name, att) result(ierr) + + use iso_c_binding, only : c_char, c_int, c_null_char, c_null_ptr, c_ptr, c_loc + + implicit none + + ! Arguments + type (SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + character(len=*), intent(in) :: att_name + character(len=*), intent(out) :: att + + ! Local variables + integer :: i + integer(kind=c_int), target :: att_type + integer(kind=SMIOL_offset_kind), target :: att_len + type (c_ptr) :: c_file + character(kind=c_char), dimension(:), allocatable, target :: c_varname + character(kind=c_char), dimension(:), pointer :: c_att_name + character(kind=c_char), dimension(:), allocatable, target :: c_att + type (c_ptr) :: att_ptr + type (c_ptr) :: att_type_ptr + type (c_ptr) :: att_len_ptr + type (c_ptr) :: c_varname_ptr + + + c_file = c_loc(file) + att_type_ptr = c_loc(att_type) + att_len_ptr = c_loc(att_len) + c_file = c_loc(file) + + ! + ! Convert Fortran string to C character array + ! + if (len_trim(varname) > 0) then + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + c_varname_ptr = c_loc(c_varname) + else + c_varname_ptr = c_null_ptr + end if + + allocate(c_att_name(len_trim(att_name) + 1)) + do i=1,len_trim(att_name) + c_att_name(i) = att_name(i:i) + end do + c_att_name(i) = c_null_char + + ! + ! First, inquire about the attribute type and length + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + att_type_ptr, att_len_ptr, c_null_ptr) + + if (ierr /= SMIOL_SUCCESS .or. att_type /= SMIOL_CHAR) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + if (ierr == SMIOL_SUCCESS) then + ierr = SMIOL_WRONG_ARG_TYPE + end if + return + end if + + if (len(att) < att_len) then + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + ierr = SMIOL_INSUFFICIENT_ARG + return + end if + + ! + ! Next, allocate a local c_char array + ! + allocate(c_att(att_len)) + att_ptr = c_loc(c_att) + + ! + ! Finally, inquire about the attribute itself + ! + ierr = SMIOL_inquire_att(c_file, c_varname_ptr, c_att_name, & + c_null_ptr, c_null_ptr, att_ptr) + + ! + ! Copy c_char array to Fortran string + ! + att(1:att_len) = transfer(c_att(1:att_len), att) + att = att(1:att_len) + + if (len_trim(varname) > 0) then + deallocate(c_varname) + end if + deallocate(c_att_name) + deallocate(c_att) + + end function SMIOLf_inquire_att_text + + + ! + ! Control methods + ! + + !----------------------------------------------------------------------- + ! routine SMIOLf_sync_file + ! + !> \brief Forces all in-memory data to be flushed to disk + !> \details + !> Upon success, all in-memory data for the file associatd with the file + !> handle will be flushed to the file system and SMIOL_SUCCESS will be + !> returned; otherwise, an error code is returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_sync_file(file) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc, c_null_ptr + + implicit none + + type (SMIOLf_file), pointer :: file + type (c_ptr) :: c_file + + interface + function SMIOL_sync_file(file) result(ierr) bind(C, name='SMIOL_sync_file') + use iso_c_binding, only : c_ptr, c_int + type(c_ptr), value :: file + integer(kind=c_int) :: ierr + end function + end interface + + c_file = c_null_ptr + + if (associated(file)) then + c_file = c_loc(file) + end if + + ierr = SMIOL_sync_file(c_file) + + end function SMIOLf_sync_file + + + !----------------------------------------------------------------------- + ! routine SMIOLf_error_string + ! + !> \brief Returns an error string for a specified error code + !> \details + !> Returns an error string corresponding to a SMIOL error code. If the error code is + !> SMIOL_LIBRARY_ERROR and a valid SMIOL context is available, the SMIOLf_lib_error_string + !> function should be called instead. + !> + !> The error string is always of length 128, and so it is recommended to trim + !> the string before it is printed. + ! + !----------------------------------------------------------------------- + character(len=128) function SMIOLf_error_string(ierrno) result(err_mesg) + + use iso_c_binding, only : c_ptr, c_char, c_null_char, c_f_pointer + + implicit none + + integer, intent(in) :: ierrno + + type (c_ptr) :: c_mesg_ptr + character(kind=c_char), dimension(:), pointer :: c_mesg + integer :: i + + ! C interface definitions + interface + function SMIOL_error_string(errno) result(err_mesg) bind(C, name='SMIOL_error_string') + use iso_c_binding, only : c_int, c_ptr + integer(kind=c_int), value :: errno + type (c_ptr) :: err_mesg + end function + end interface + + c_mesg_ptr = SMIOL_error_string(ierrno) + call c_f_pointer(c_mesg_ptr, c_mesg, shape=[len(err_mesg)]) + + do i=1,len(err_mesg) + if (c_mesg(i) == c_null_char) exit + end do + + i = i - 1 + + err_mesg(1:i) = transfer(c_mesg(1:i), err_mesg) + err_mesg = err_mesg(1:i) + + end function SMIOLf_error_string + + + !----------------------------------------------------------------------- + ! routine SMIOLf_lib_error_string + ! + !> \brief Returns an error string for a third-party library called by SMIOL + !> \details + !> Returns an error string corresponding to an error that was generated by + !> a third-party library that was called by SMIOL. The library that was the source + !> of the error, as well as the library-specific error code, are retrieved from + !> a SMIOL context. If successive library calls resulted in errors, only the error + !> string for the last of these errors will be returned. + !> + !> The error string is always of length 128, and so it is recommended to trim + !> the string before it is printed. + ! + !----------------------------------------------------------------------- + character(len=128) function SMIOLf_lib_error_string(context) result(err_mesg) + + use iso_c_binding, only : c_ptr, c_null_ptr, c_char, c_null_char, c_f_pointer, c_loc + + implicit none + + type (SMIOLf_context), target :: context + + type (c_ptr) :: c_context = c_null_ptr + type (c_ptr) :: c_mesg_ptr = c_null_ptr + character(kind=c_char), dimension(:), pointer :: c_mesg => null() + integer :: i + + ! C interface definitions + interface + function SMIOL_lib_error_string(context) result(err_mesg) bind(C, name='SMIOL_lib_error_string') + use iso_c_binding, only : c_ptr + type(c_ptr), value :: context + type (c_ptr) :: err_mesg + end function + end interface + + c_context = c_loc(context) + + c_mesg_ptr = SMIOL_lib_error_string(c_context) + call c_f_pointer(c_mesg_ptr, c_mesg, shape=[len(err_mesg)]) + + do i=1,len(err_mesg) + if (c_mesg(i) == c_null_char) exit + end do + + i = i - 1 + + err_mesg(1:i) = transfer(c_mesg(1:i), err_mesg) + err_mesg = err_mesg(1:i) + + end function SMIOLf_lib_error_string + + + !----------------------------------------------------------------------- + ! routine SMIOLf_set_option + ! + !> \brief Sets an option for the SMIOL library + !> \details + !> Detailed description of what this routine does. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_set_option() result(ierr) + + implicit none + + ierr = 0 + + end function SMIOLf_set_option + + !----------------------------------------------------------------------- + ! routine SMIOLf_set_frame + ! + !> \brief Set the frame of an open file + !> \details + !> For an open SMIOL file handle, set the frame for the unlimited dimension. + !> After setting the frame for a file, writing to a variable that is + !> dimensioned by the unlimited dimension will write to the last set frame, + !> overwriting any current data that maybe present in that frame. + !> + !> SMIOL_SUCCESS will be returned if the frame is successfully set otherwise an + !> error will return. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_set_frame(file, frame) result(ierr) + + use iso_c_binding, only : c_loc, c_ptr + + implicit none + + type (SMIOLf_file), target :: file + integer (kind=SMIOL_offset_kind), value, intent(in) :: frame + + type (c_ptr) :: c_file + + ! C interface definitions + interface + function SMIOL_set_frame(file, frame) result(ierr) bind(C, name='SMIOL_set_frame') + use iso_c_binding, only : c_ptr, c_int + import SMIOL_offset_kind + type (c_ptr), value :: file + integer (kind=SMIOL_offset_kind), value :: frame + integer (kind=c_int) :: ierr + end function + end interface + + c_file = c_loc(file) + ierr = SMIOL_set_frame(c_file, frame) + + end function SMIOLf_set_frame + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_frame + ! + !> \brief Get the frame of an open file + !> \details + !> Get the current frame of an open file. Upon success, SMIOL_SUCCESS will be + !> returned, otherwise an error will be returned. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_get_frame(file, frame) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc + + implicit none + + type (SMIOLf_file), target, intent(in) :: file + integer (kind=SMIOL_offset_kind), target, intent(out) :: frame + + type (c_ptr) :: c_file + type (c_ptr) :: c_frame + + ! C interface definitions + interface + function SMIOL_get_frame(file, frame) result(ierr) bind(C, name='SMIOL_get_frame') + use iso_c_binding, only : c_ptr, c_int + type (c_ptr), value :: file + type (c_ptr), value :: frame + integer (kind=c_int) :: ierr + end function + end interface + + c_file = c_loc(file) + c_frame = c_loc(frame) + ierr = SMIOL_get_frame(c_file, c_frame) + + end function SMIOLf_get_frame + + + !----------------------------------------------------------------------- + ! routine SMIOLf_create_decomp + ! + !> \brief Creates a mapping between compute elements and I/O elements + !> \details + !> Given arrays of global element IDs that each task computes, this routine + !> works out a mapping of elements between compute and I/O tasks. + !> + !> The aggregation factor is used to indicate the size of subsets of ranks + !> that will gather fields onto a single rank in each subset before transferring + !> that field from compute to output tasks; in a symmetric way, it also + !> indicates the size of subsets over which fields will be scattered after they + !> are transferred from input tasks to a single compute tasks in each subset. + !> + !> An aggregation factor of 0 indicates that the implementation should choose + !> a suitable aggregation factor (usually matching the size of shared-memory + !> domains), while a positive integer specifies a specific size for task groups + !> to be used for aggregation. + !> + !> If the optional aggregation_factor argument is not given, it defaults to + !> a value of 0. + !> + !> If all input arguments are determined to be valid and if the routine is + !> successful in working out a mapping, the decomp pointer is allocated + !> and given valid contents, and SMIOL_SUCCESS is returned; otherwise + !> a non-success error code is returned and the decomp pointer is unassociated. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_create_decomp(context, n_compute_elements, compute_elements, decomp, & + aggregation_factor) result(ierr) + + use iso_c_binding, only : c_int, c_size_t, c_ptr, c_null_ptr, c_loc, c_f_pointer, c_associated + + implicit none + + ! Arguments + type (SMIOLf_context), target, intent(in) :: context + integer(kind=c_size_t), intent(in) :: n_compute_elements + integer(kind=SMIOL_offset_kind), dimension(n_compute_elements), target, intent(in) :: compute_elements + type (SMIOLf_decomp), pointer, intent(inout) :: decomp + integer, intent(in), optional :: aggregation_factor + + ! Local variables + type (c_ptr) :: c_context + type (c_ptr) :: c_decomp + type (c_ptr) :: c_compute_elements + integer(kind=c_int) :: c_agg_factor + + interface + function SMIOL_create_decomp(context, n_compute_elements, compute_elements, aggregation_factor, decomp) & + result(ierr) bind(C, name='SMIOL_create_decomp') + use iso_c_binding, only : c_size_t, c_ptr, c_int + type (c_ptr), value :: context + integer(c_size_t), value :: n_compute_elements + type (c_ptr), value :: compute_elements + integer(kind=c_int), value :: aggregation_factor + integer(kind=c_int) :: ierr + type (c_ptr) :: decomp + end function + end interface + + + if (present(aggregation_factor)) then + c_agg_factor = aggregation_factor + else + c_agg_factor = 0 ! Let SMIOL choose its own aggregation factor + end if + + ! Get C pointers to Fortran types + c_context = c_loc(context) + if (size(compute_elements) > 0) then + c_compute_elements = c_loc(compute_elements) + else + c_compute_elements = c_null_ptr + end if + + c_decomp = c_null_ptr + + ierr = SMIOL_create_decomp(c_context, n_compute_elements, c_compute_elements, c_agg_factor, c_decomp) + + ! Error check and translate c_decomp pointer into a Fortran SMIOLf_decomp pointer + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_decomp)) then + call c_f_pointer(c_decomp, decomp) + else + nullify(decomp) + ierr = SMIOL_FORTRAN_ERROR + end if + else + nullify(decomp) + if (c_associated(c_decomp)) then + ierr = SMIOL_FORTRAN_ERROR + endif + end if + + end function SMIOLf_create_decomp + + + !----------------------------------------------------------------------- + ! routine SMIOLf_free_decomp + ! + !> \brief Frees a mapping between compute elements and I/O elements + !> \details + !> Frees all memory of a SMIOLf_decomp and returns SMIOL_SUCCESS. If + !> decomp is unassociated, nothing will be done and SMIOL_SUCCESS will + !> be returned. After this function has been called, no other SMIOL + !> routines should use the freed SMIOL_decomp. + ! + !----------------------------------------------------------------------- + integer function SMIOLf_free_decomp(decomp) result(ierr) + + use iso_c_binding, only : c_ptr, c_loc, c_associated, c_null_ptr + + implicit none + + type(SMIOLF_decomp), pointer, intent(inout) :: decomp + type(c_ptr) :: c_decomp = c_null_ptr + + interface + function SMIOL_free_decomp(decomp) result(ierr) bind(C, name='SMIOL_free_decomp') + use iso_c_binding, only : c_ptr, c_int + type(c_ptr) :: decomp + integer(kind=c_int) :: ierr + end function + end interface + + ierr = SMIOL_SUCCESS + + if (associated(decomp)) then + c_decomp = c_loc(decomp) + endif + ierr = SMIOL_free_decomp(c_decomp) + + if (ierr == SMIOL_SUCCESS) then + if (c_associated(c_decomp)) then + ierr = SMIOL_FORTRAN_ERROR + else + nullify(decomp) + end if + else + if (.not. c_associated(c_decomp)) then + nullify(decomp) + end if + end if + + end function SMIOLf_free_decomp + + !----------------------------------------------------------------------- + ! routine SMIOLf_f_to_c_string + ! + !> \brief Convert a Fortran string to a C null-terminated character array + !> \details + !> Converts a Fortran string to a C null-terminated character array. + !> The cstring output argument must be large enough to contain the trimmed + !> Fortran string plus at least one c_null_char character. Any characters + !> beyond len_trim(fstring) of cstring will be filled with c_null_char + !> characters. If the size of cstring is less than len_trim(fstring)+1, + !> then only size(cstring)-1 characters from fstring will be copied into + !> cstring before the final c_null_char character is added. + ! + !----------------------------------------------------------------------- + subroutine SMIOLf_f_to_c_string(fstring, cstring) + + use iso_c_binding, only : c_char, c_null_char + + implicit none + + character(len=*), intent(in) :: fstring + character(kind=c_char), dimension(:), intent(out) :: cstring + + integer :: i + integer :: nchar + + if (size(cstring) <= 0) then + return + end if + + nchar = min(size(cstring)-1, len_trim(fstring)) + + do i = 1, nchar + cstring(i) = fstring(i:i) + end do + cstring(nchar+1:size(cstring)) = c_null_char + + end subroutine SMIOLf_f_to_c_string + +end module SMIOLf diff --git a/src/external/SMIOL/smiolf_put_get_var.inc b/src/external/SMIOL/smiolf_put_get_var.inc new file mode 100644 index 0000000000..1ad9e744ed --- /dev/null +++ b/src/external/SMIOL/smiolf_put_get_var.inc @@ -0,0 +1,3994 @@ + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_char + ! + !> \brief Writes a 0-d char variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_char(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_char, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + character(len=:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + character(kind=c_char), dimension(:), allocatable, target :: char_buf + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + allocate(char_buf(len(buf))) + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do + c_buf = c_loc(char_buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + if (associated(buf)) then + deallocate(char_buf) + end if + deallocate(c_varname) + + end function SMIOLf_put_var_0d_char + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_char + ! + !> \brief Reads a 0-d char variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_char(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_char, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + character(len=:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + character(kind=c_char), dimension(:), allocatable, target :: char_buf + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + allocate(char_buf(len(buf))) + + ! In case buf contains more characters than will be read from the file, + ! initialize char_buf with the contents of buf to preserve un-read + ! characters during the copy of char_buf back into buf later on + do i=1,len(buf) + char_buf(i) = buf(i:i) + end do + c_buf = c_loc(char_buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + if (associated(buf)) then + do i=1,len(buf) + buf(i:i) = char_buf(i) + end do + + deallocate(char_buf) + end if + deallocate(c_varname) + + end function SMIOLf_get_var_0d_char + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_real32 + ! + !> \brief Writes a 0-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_0d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_real32 + ! + !> \brief Reads a 0-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_0d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_real64 + ! + !> \brief Writes a 0-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_0d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_real64 + ! + !> \brief Reads a 0-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_0d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d0_int32 + ! + !> \brief Writes a 0-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_0d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_0d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d0_int32 + ! + !> \brief Reads a 0-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_0d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + c_buf = c_loc(buf) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_0d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_1d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_1d_real32(a, d1) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1 + real(kind=c_float), dimension(d1), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_1d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d1_real32 + ! + !> \brief Writes a 1-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_1d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_1d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d1_real32 + ! + !> \brief Reads a 1-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_1d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_1d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_1d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_1d_real64(a, d1) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1 + real(kind=c_double), dimension(d1), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_1d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d1_real64 + ! + !> \brief Writes a 1-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_1d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real64(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_1d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d1_real64 + ! + !> \brief Reads a 1-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_1d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_real64(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_1d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_1d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_1d_int32(a, d1) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1 + integer(kind=c_int), dimension(d1), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_1d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d1_int32 + ! + !> \brief Writes a 1-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_1d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_int32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_1d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d1_int32 + ! + !> \brief Reads a 1-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_1d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_1d_int32(buf, size(buf,dim=1)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_1d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_2d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_2d_real32(a, d1, d2) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2 + real(kind=c_float), dimension(d1,d2), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_2d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d2_real32 + ! + !> \brief Writes a 2-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_2d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_2d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d2_real32 + ! + !> \brief Reads a 2-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_2d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_2d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_2d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_2d_real64(a, d1, d2) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2 + real(kind=c_double), dimension(d1,d2), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_2d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d2_real64 + ! + !> \brief Writes a 2-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_2d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real64(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_2d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d2_real64 + ! + !> \brief Reads a 2-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_2d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_real64(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_2d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_2d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_2d_int32(a, d1, d2) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2 + integer(kind=c_int), dimension(d1,d2), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_2d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d2_int32 + ! + !> \brief Writes a 2-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_2d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_int32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_2d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d2_int32 + ! + !> \brief Reads a 2-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_2d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_2d_int32(buf, size(buf,dim=1), size(buf,dim=2)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_2d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_3d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_3d_real32(a, d1, d2, d3) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3 + real(kind=c_float), dimension(d1,d2,d3), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_3d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d3_real32 + ! + !> \brief Writes a 3-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_3d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_3d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d3_real32 + ! + !> \brief Reads a 3-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_3d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_3d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_3d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_3d_real64(a, d1, d2, d3) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3 + real(kind=c_double), dimension(d1,d2,d3), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_3d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d3_real64 + ! + !> \brief Writes a 3-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_3d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_3d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d3_real64 + ! + !> \brief Reads a 3-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_3d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_3d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_3d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_3d_int32(a, d1, d2, d3) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3 + integer(kind=c_int), dimension(d1,d2,d3), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_3d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d3_int32 + ! + !> \brief Writes a 3-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_3d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_3d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d3_int32 + ! + !> \brief Reads a 3-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_3d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_3d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_3d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_4d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_4d_real32(a, d1, d2, d3, d4) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4 + real(kind=c_float), dimension(d1,d2,d3,d4), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_4d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d4_real32 + ! + !> \brief Writes a 4-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_4d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_4d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d4_real32 + ! + !> \brief Reads a 4-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_4d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_4d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_4d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_4d_real64(a, d1, d2, d3, d4) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4 + real(kind=c_double), dimension(d1,d2,d3,d4), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_4d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d4_real64 + ! + !> \brief Writes a 4-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_4d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_4d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d4_real64 + ! + !> \brief Reads a 4-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_4d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_4d_real64 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_4d_int32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_4d_int32(a, d1, d2, d3, d4) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_int + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4 + integer(kind=c_int), dimension(d1,d2,d3,d4), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_4d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d4_int32 + ! + !> \brief Writes a 4-d int32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_4d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_4d_int32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d4_int32 + ! + !> \brief Reads a 4-d int32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_4d_int32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_int, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + integer(kind=c_int), dimension(:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_4d_int32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_4d_int32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_5d_real32 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_5d_real32(a, d1, d2, d3, d4, d5) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_float + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4, d5 + real(kind=c_float), dimension(d1,d2,d3,d4,d5), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_5d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d5_real32 + ! + !> \brief Writes a 5-d real32 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_5d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_5d_real32 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d5_real32 + ! + !> \brief Reads a 5-d real32 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_5d_real32(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_float, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_float), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real32(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_5d_real32 + + + !----------------------------------------------------------------------- + ! routine c_loc_assumed_shape_5d_real64 + ! + !> \brief Returns a C_PTR for an array with given dimensions + !> \details + !> The Fortran 2003 standard does not permit the use of C_LOC with + !> assumed shape arrays. This routine may be used to obtain a C_PTR for + !> an assumed shape array by invoking the routine with the first actual + !> argument as the assumed-shape array, and subsequent actual arguments + !> as, e.g., SIZE(a,DIM=1). + !> + !> Internally, the first dummy argument of this routine can be declared + !> as an explicit shape array, which can then be used as an argument to + !> C_LOC. + !> + !> Upon success, a C_PTR for the array argument is returned. + !> + !> Note: The actual array argument must not be a zero-sized array. + !> Section 15.1.2.5 of the Fortran 2003 standard specifies that + !> the argument to C_LOC '...is not an array of zero size...'. + ! + !----------------------------------------------------------------------- + function c_loc_assumed_shape_5d_real64(a, d1, d2, d3, d4, d5) result(a_ptr) + + use iso_c_binding, only : c_ptr, c_loc, c_double + + implicit none + + ! Arguments + integer, intent(in) :: d1, d2, d3, d4, d5 + real(kind=c_double), dimension(d1,d2,d3,d4,d5), target, intent(in) :: a + + ! Return value + type (c_ptr) :: a_ptr + + a_ptr = c_loc(a) + + end function c_loc_assumed_shape_5d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_put_var_d5_real64 + ! + !> \brief Writes a 5-d real64 variable to a file. + !> \details + !> Given a SMIOL file that was previously opened with write access and the name + !> of a variable previously defined in the file with a call to SMIOLf_define_var, + !> this routine will write the contents of buf to the variable according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks store identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. As currently implemented, this routine will write + !> the buffer for MPI rank 0 to the variable; however, this behavior should not + !> be relied on. + !> + !> If the variable has been successfully written to the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_put_var_5d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_put_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_put_var_5d_real64 + + + !----------------------------------------------------------------------- + ! routine SMIOLf_get_var_d5_real64 + ! + !> \brief Reads a 5-d real64 variable from a file. + !> \details + !> Given a SMIOL file and the name of a variable previously defined in the file, + !> this routine will read the contents of the variable into buf according to + !> the decomposition described by decomp. + !> + !> If decomp is an associated pointer, the variable is assumed to be decomposed + !> across MPI ranks, and all ranks with non-zero-sized partitions of the variable + !> must provide a valid buffer. For decomposed variables, all MPI ranks must provide + !> an associated decomp pointer, regardless of whether a rank has a non-zero-sized + !> partition of the variable. + !> + !> If the variable is not decomposed -- that is, all ranks load identical + !> values for the entire variable -- all MPI ranks must provide an unassociated + !> pointer for the decomp argument. + !> + !> If the variable has been successfully read from the file, SMIOL_SUCCESS will + !> be returned. Otherwise, an error code indicating the nature of the failure + !> will be returned. + ! + !----------------------------------------------------------------------- + function SMIOLf_get_var_5d_real64(file, varname, decomp, buf) result(ierr) + + use iso_c_binding, only : c_double, c_char, c_loc, c_ptr, c_null_ptr, c_null_char + + implicit none + + ! Arguments + type(SMIOLf_file), target :: file + character(len=*), intent(in) :: varname + type(SMIOLf_decomp), pointer :: decomp + real(kind=c_double), dimension(:,:,:,:,:), pointer :: buf + + ! Return status code + integer :: ierr + + ! Local variables + integer :: i + character(kind=c_char), dimension(:), pointer :: c_varname + type (c_ptr) :: c_file + type (c_ptr) :: c_decomp + type (c_ptr) :: c_buf + + + ! + ! file is a target, so no need to check that it is associated + ! + c_file = c_loc(file) + + ! + ! decomp may be an unassociated pointer if the corresponding field is + ! not decomposed + ! + if (associated(decomp)) then + c_decomp = c_loc(decomp) + else + c_decomp = c_null_ptr + end if + + ! + ! Convert variable name string + ! + allocate(c_varname(len_trim(varname) + 1)) + do i=1,len_trim(varname) + c_varname(i) = varname(i:i) + end do + c_varname(i) = c_null_char + + ! + ! buf may be an unassociated pointer if the calling task does not read + ! or write any elements of the field + ! + if (associated(buf)) then + + ! + ! Invoke a Fortran 2003-compliant function to get the c_ptr + ! of the assumed shape array buf + ! + c_buf = c_loc_assumed_shape_5d_real64(buf, size(buf,dim=1), size(buf,dim=2), size(buf,dim=3), & + size(buf,dim=4), size(buf,dim=5)) + else + c_buf = c_null_ptr + end if + + ierr = SMIOL_get_var(c_file, c_varname, c_decomp, c_buf) + + + deallocate(c_varname) + + end function SMIOLf_get_var_5d_real64 + + diff --git a/src/external/esmf_time_f90/CMakeLists.txt b/src/external/esmf_time_f90/CMakeLists.txt new file mode 100644 index 0000000000..6546880fb4 --- /dev/null +++ b/src/external/esmf_time_f90/CMakeLists.txt @@ -0,0 +1,34 @@ + +set(_esmf_time_src + ESMF_AlarmClockMod.F90 + ESMF_AlarmMod.F90 + ESMF_BaseMod.F90 + ESMF_BaseTimeMod.F90 + ESMF_CalendarMod.F90 + ESMF_ClockMod.F90 + ESMF.F90 + ESMF_FractionMod.F90 + ESMF_Macros.inc + ESMF_ShrTimeMod.F90 + ESMF_Stubs.F90 + ESMF_TimeIntervalMod.F90 + ESMF_TimeMgr.inc + ESMF_TimeMod.F90 + MeatMod.F90 + wrf_error_fatal.F90 + wrf_message.F90) + +add_library(esmf ${_esmf_time_src}) +mpas_fortran_target(esmf) +add_library(${PROJECT_NAME}::external::esmf ALIAS esmf) + +target_compile_definitions(esmf PRIVATE HIDE_MPI=1) + +target_include_directories(esmf PUBLIC $) + +target_link_libraries(esmf PUBLIC MPI::MPI_Fortran) + +install(TARGETS esmf EXPORT ${PROJECT_NAME}ExportsExternal + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) + diff --git a/src/external/esmf_time_f90/ESMF_BaseMod.F90 b/src/external/esmf_time_f90/ESMF_BaseMod.F90 index 435ca8d02a..3e1294c0cb 100644 --- a/src/external/esmf_time_f90/ESMF_BaseMod.F90 +++ b/src/external/esmf_time_f90/ESMF_BaseMod.F90 @@ -68,11 +68,23 @@ module ESMF_BaseMod ESMF_STATE_BUSY = ESMF_Status(5), & ESMF_STATE_INVALID = ESMF_Status(6) +!------------------------------------------------------------------------------ +! + integer, parameter :: & + ESMF_KIND_I1 = selected_int_kind(2), & + ESMF_KIND_I2 = selected_int_kind(4), & + ESMF_KIND_I4 = selected_int_kind(9), & + ESMF_KIND_I8 = selected_int_kind(18), & + ESMF_KIND_R4 = selected_real_kind(3,25), & + ESMF_KIND_R8 = selected_real_kind(6,45), & + ESMF_KIND_C8 = selected_real_kind(3,25), & + ESMF_KIND_C16 = selected_real_kind(6,45) + !------------------------------------------------------------------------------ ! type ESMF_Pointer private - integer*8 :: ptr + integer(kind=ESMF_KIND_I8) :: ptr end type type(ESMF_Pointer), parameter :: ESMF_NULL_POINTER = ESMF_Pointer(0), & @@ -95,18 +107,6 @@ module ESMF_BaseMod ESMF_DATA_LOGICAL = ESMF_DataType(3), & ESMF_DATA_CHARACTER = ESMF_DataType(4) -!------------------------------------------------------------------------------ - - integer, parameter :: & - ESMF_KIND_I1 = selected_int_kind(2), & - ESMF_KIND_I2 = selected_int_kind(4), & - ESMF_KIND_I4 = selected_int_kind(9), & - ESMF_KIND_I8 = selected_int_kind(18), & - ESMF_KIND_R4 = selected_real_kind(3,25), & - ESMF_KIND_R8 = selected_real_kind(6,45), & - ESMF_KIND_C8 = selected_real_kind(3,25), & - ESMF_KIND_C16 = selected_real_kind(6,45) - !------------------------------------------------------------------------------ type ESMF_DataValue @@ -160,7 +160,7 @@ module ESMF_BaseMod ! type ESMF_BasePointer private - integer*8 :: base_ptr + integer(kind=ESMF_KIND_I8) :: base_ptr end type integer :: global_count = 0 @@ -950,7 +950,7 @@ subroutine ESMF_SetPointer(ptype, contents, rc) ! ! !ARGUMENTS: type(ESMF_Pointer) :: ptype - integer*8, intent(in) :: contents + integer(kind=ESMF_KIND_I8), intent(in) :: contents integer, intent(out), optional :: rc ! @@ -985,7 +985,7 @@ subroutine ESMF_SetNullPointer(ptype, rc) ! !EOP ! !REQUIREMENTS: - integer*8, parameter :: nullp = 0 + integer(kind=ESMF_KIND_I8), parameter :: nullp = 0 ptype%ptr = nullp if (present(rc)) rc = ESMF_SUCCESS @@ -999,7 +999,7 @@ end subroutine ESMF_SetNullPointer function ESMF_GetPointer(ptype, rc) ! ! !RETURN VALUE: - integer*8 :: ESMF_GetPointer + integer(kind=ESMF_KIND_I8) :: ESMF_GetPointer ! !ARGUMENTS: type(ESMF_Pointer), intent(in) :: ptype diff --git a/src/external/ezxml/CMakeLists.txt b/src/external/ezxml/CMakeLists.txt new file mode 100644 index 0000000000..34955dbd98 --- /dev/null +++ b/src/external/ezxml/CMakeLists.txt @@ -0,0 +1,8 @@ + +add_library(ezxml ezxml.c) +add_library(${PROJECT_NAME}::external::ezxml ALIAS ezxml) +target_include_directories(ezxml PUBLIC $) + +install(TARGETS ezxml EXPORT ${PROJECT_NAME}ExportsExternal + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/external/ezxml/Makefile b/src/external/ezxml/Makefile index b7d1633363..93c192920c 100644 --- a/src/external/ezxml/Makefile +++ b/src/external/ezxml/Makefile @@ -1,14 +1,5 @@ -.SUFFIXES: .c .o - -OBJS = ezxml.o - -all: clean - $(MAKE) -j 1 library - -library: $(OBJS) +$(OBJFILE): ezxml.c + $(CC) $(CFLAGS) $(CPPFLAGS) -c $< -o $(OBJFILE) clean: $(RM) *.o *.i - -.c.o: - $(CC) $(CFLAGS) $(CPPFLAGS) -c $< diff --git a/src/framework/CMakeLists.txt b/src/framework/CMakeLists.txt new file mode 100644 index 0000000000..535ba07891 --- /dev/null +++ b/src/framework/CMakeLists.txt @@ -0,0 +1,70 @@ + +set(MPAS_FRAMEWORK_SOURCES + mpas_block_creator.F + mpas_block_decomp.F + mpas_bootstrapping.F + mpas_c_interfacing.F + mpas_constants.F + mpas_decomp.F + mpas_domain_routines.F + mpas_field_routines.F + mpas_forcing.F + mpas_hash.F + mpas_io_units.F + mpas_kind_types.F + mpas_pool_routines.F + mpas_sort.F + mpas_stream_list.F + mpas_threading.F + mpas_timer.F + mpas_abort.F + mpas_attlist.F + mpas_derived_types.F + mpas_dmpar.F + mpas_framework.F + mpas_halo.F + mpas_io.F + mpas_io_streams.F + mpas_log.F + mpas_stream_inquiry.F + mpas_stream_manager.F + mpas_string_utils.F + mpas_timekeeping.F + pool_hash.c + random_id.c + regex_matching.c + xml_stream_parser.c + stream_inquiry.c) + +add_library(framework ${MPAS_FRAMEWORK_SOURCES}) +set_MPAS_DEBUG_flag(framework) +set(FRAMEWORK_COMPILE_DEFINITIONS + USE_PIO2 + MPAS_PIO_SUPPORT + mpas=1 + MPAS_NATIVE_TIMERS) +target_compile_definitions(framework PRIVATE ${FRAMEWORK_COMPILE_DEFINITIONS}) + +mpas_fortran_target(framework) +add_library(${PROJECT_NAME}::framework ALIAS framework) + +set_target_properties(framework PROPERTIES OUTPUT_NAME mpas_framework) + +set(FRAMEWORK_LINK_LIBRARIES + ${PROJECT_NAME}::external::esmf + ${PROJECT_NAME}::external::ezxml + PIO::PIO_Fortran + PIO::PIO_C + PnetCDF::PnetCDF_Fortran + NetCDF::NetCDF_Fortran + NetCDF::NetCDF_C + MPI::MPI_Fortran) + +if (MPAS_PROFILE) + list(APPEND FRAMEWORK_LINK_LIBRARIES GPTL::GPTL) +endif () +target_link_libraries(framework PUBLIC ${FRAMEWORK_LINK_LIBRARIES}) + +install(TARGETS framework EXPORT ${PROJECT_NAME}Exports + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/framework/Makefile b/src/framework/Makefile index d19cd78677..2d8e7dc92b 100644 --- a/src/framework/Makefile +++ b/src/framework/Makefile @@ -33,8 +33,11 @@ OBJS = mpas_kind_types.o \ mpas_pool_routines.o \ xml_stream_parser.o \ regex_matching.o \ - mpas_field_accessor.o \ - mpas_log.o + mpas_log.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 @@ -107,7 +110,9 @@ mpas_c_interfacing.o: xml_stream_parser.o: xml_stream_parser.c $(CC) $(CFLAGS) $(CPPFLAGS) $(CPPINCLUDES) -I../external/ezxml -c xml_stream_parser.c -mpas_field_accessor.o: mpas_derived_types.o mpas_kind_types.o mpas_pool_routines.o mpas_log.o +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 diff --git a/src/framework/mpas_abort.F b/src/framework/mpas_abort.F index 6dddc941e1..e00a3cfd67 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, only : MPI_COMM_WORLD, MPI_Comm_rank, MPI_Comm_size, MPI_Abort +#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_attlist_types.inc b/src/framework/mpas_attlist_types.inc index 8c664bdcbe..b69768833a 100644 --- a/src/framework/mpas_attlist_types.inc +++ b/src/framework/mpas_attlist_types.inc @@ -11,7 +11,7 @@ ! Derived type for holding field attributes type att_list_type character (len=StrKIND) :: attName = '' - integer :: attType = -1 + integer :: attType = -1 ! Should not match any of MPAS_ATT_INT, MPAS_ATT_REAL, etc. integer :: attValueInt integer, dimension(:), pointer :: attValueIntA => null() real (kind=RKIND) :: attValueReal diff --git a/src/framework/mpas_block_creator.F b/src/framework/mpas_block_creator.F index 488beef2b0..42070c04b8 100644 --- a/src/framework/mpas_block_creator.F +++ b/src/framework/mpas_block_creator.F @@ -20,6 +20,9 @@ ! !----------------------------------------------------------------------- +#define REPORT_FIELD_ALLOCATION(F,B) ! call field_allocate_mesg(F, B) +#define REPORT_TOTAL_ALLOCATION(B) ! call total_allocated_mesg(B) + module mpas_block_creator use mpas_dmpar @@ -1228,6 +1231,10 @@ subroutine mpas_block_creator_finalize_block_phase2(stream_manager, blocklist, r integer, pointer :: dim0d integer, dimension(:), pointer :: dim1d + integer(kind=I8KIND) :: allocated_bytes + integer :: total_allocated_mb + + domain => blocklist % domain ! Loop over blocks @@ -1266,7 +1273,22 @@ subroutine mpas_block_creator_finalize_block_phase2(stream_manager, blocklist, r call mpas_log_write('Derived dimension setup failed for core ' // trim(block_ptr % domain % core % coreName), MPAS_LOG_CRIT) end if - call mpas_block_creator_allocate_pool_fields(block_ptr % structs, block_ptr % dimensions) + + call mpas_log_write('Allocating fields ...') + allocated_bytes = 0_I8KIND + + call mpas_block_creator_allocate_pool_fields(block_ptr % structs, block_ptr % dimensions, allocated_bytes, ierr) + if (ierr /= 0) then + call mpas_log_write('Allocation of fields failed for core ' // trim(block_ptr % domain % core % coreName), MPAS_LOG_CRIT) + end if + + call mpas_log_write(' $i MB allocated for fields on this task', intArgs=[int(allocated_bytes / 1000000_I8KIND)]) + if (domain % dminfo % nprocs > 1) then + call mpas_dmpar_sum_int(domain % dminfo, int(allocated_bytes / 1000000_I8KIND), total_allocated_mb) + call mpas_log_write(' $i MB total allocated for fields across all tasks', intArgs=[total_allocated_mb]) + end if + call mpas_log_write(' ----- done allocating fields -----') + call mpas_log_write('') err_level = mpas_pool_get_error_level() call mpas_pool_set_error_level(MPAS_POOL_SILENT) @@ -1534,9 +1556,20 @@ end subroutine mpas_block_creator_reindex_block_fields!}}} !> This routine also copies all dimensions from dimensionPool to currentPool ! !----------------------------------------------------------------------- - recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimensionPool)!{{{ + recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimensionPool, allocated_bytes, ierr)!{{{ + type (mpas_pool_type), pointer :: currentPool !< Input: Current pool to allocate and copy dimensions. type (mpas_pool_type), pointer :: dimensionPool !< Input: Pool of dimensions for the current block + integer(kind=I8KIND), intent(inout) :: allocated_bytes !< Input/Output: The total number of bytes allocated for fields + integer, intent(out) :: ierr !< Output: Return status code, 0 = success + +#ifdef SINGLE_PRECISION + integer(kind=I8KIND), parameter :: real_size = 4_I8KIND +#else + integer(kind=I8KIND), parameter :: real_size = 8_I8KIND +#endif + integer(kind=I8KIND), parameter :: int_size = 4_I8KIND + type (mpas_pool_type), pointer :: subPool type (mpas_pool_iterator_type) :: poolItr @@ -1555,6 +1588,11 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens integer, dimension(:), pointer :: tempDim1D integer :: dimSize integer :: localErr + integer :: ierr_alloc + + integer(kind=I8KIND) :: field_bytes + + ierr = 0 call mpas_pool_begin_iteration(dimensionPool) do while( mpas_pool_get_next_member(dimensionPool, poolItr) ) @@ -1573,7 +1611,11 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens do while ( mpas_pool_get_next_member(currentPool, poolItr) ) if ( poolItr % memberType == MPAS_POOL_SUBPOOL ) then call mpas_pool_get_subpool(currentPool, poolItr % memberName, subPool) - call mpas_block_creator_allocate_pool_fields(subPool, dimensionPool) + call mpas_block_creator_allocate_pool_fields(subPool, dimensionPool, allocated_bytes, ierr) + if (ierr /= 0) then + call mpas_log_write('failed to allocate fields in pool '//trim(poolItr % memberName), messageType=MPAS_LOG_ERR) + return + end if else if ( poolItr % memberType == MPAS_POOL_FIELD ) then if ( poolItr % dataType == MPAS_POOL_REAL ) then if ( poolItr % nDims == 1 ) then @@ -1592,7 +1634,16 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real1DField % isPersistent ) then - allocate(real1DField % array(real1DField % dimSizes(1))) + field_bytes = int(real1DField % dimSizes(1), kind=I8KIND) * real_size + REPORT_FIELD_ALLOCATION(real1DField % fieldName, field_bytes) + allocate(real1DField % array(real1DField % dimSizes(1)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real1DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real1DField % array(:) = real1DField % defaultValue end if end if @@ -1612,7 +1663,18 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real2DField % isPersistent ) then - allocate(real2DField % array(real2DField % dimSizes(1), real2DField % dimSizes(2))) + field_bytes = int(real2DField % dimSizes(1), kind=I8KIND) & + * int(real2DField % dimSizes(2), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real2DField % fieldName, field_bytes) + allocate(real2DField % array(real2DField % dimSizes(1), real2DField % dimSizes(2)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real2DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real2DField % array(:,:) = real2DField % defaultValue end if end if @@ -1632,7 +1694,20 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real3DField % isPersistent ) then - allocate(real3DField % array(real3DField % dimSizes(1), real3DField % dimSizes(2), real3DField % dimSizes(3))) + field_bytes = int(real3DField % dimSizes(1), kind=I8KIND) & + * int(real3DField % dimSizes(2), kind=I8KIND) & + * int(real3DField % dimSizes(3), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real3DField % fieldName, field_bytes) + allocate(real3DField % array(real3DField % dimSizes(1), real3DField % dimSizes(2), & + real3DField % dimSizes(3)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real3DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real3DField % array(:,:,:) = real3DField % defaultValue end if end if @@ -1652,8 +1727,22 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real4DField % isPersistent ) then + field_bytes = int(real4DField % dimSizes(1), kind=I8KIND) & + * int(real4DField % dimSizes(2), kind=I8KIND) & + * int(real4DField % dimSizes(3), kind=I8KIND) & + * int(real4DField % dimSizes(4), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real4DField % fieldName, field_bytes) allocate(real4DField % array(real4DField % dimSizes(1), real4DField % dimSizes(2), & - real4DField % dimSizes(3), real4DField % dimSizes(4))) + real4DField % dimSizes(3), real4DField % dimSizes(4)), & + stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real4DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real4DField % array(:,:,:,:) = real4DField % defaultValue end if end if @@ -1673,9 +1762,23 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( real5DField % isPersistent ) then + field_bytes = int(real5DField % dimSizes(1), kind=I8KIND) & + * int(real5DField % dimSizes(2), kind=I8KIND) & + * int(real5DField % dimSizes(3), kind=I8KIND) & + * int(real5DField % dimSizes(4), kind=I8KIND) & + * int(real5DField % dimSizes(5), kind=I8KIND) & + * real_size + REPORT_FIELD_ALLOCATION(real5DField % fieldName, field_bytes) allocate(real5DField % array(real5DField % dimSizes(1), real5DField % dimSizes(2), & real5DField % dimSizes(3), real5DField % dimSizes(4), & - real5DField % dimSizes(5))) + real5DField % dimSizes(5)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(real5DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) real5DField % array(:,:,:,:,:) = real5DField % defaultValue end if end if @@ -1697,7 +1800,16 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( int1DField % isPersistent ) then - allocate(int1DField % array(int1DField % dimSizes(1))) + field_bytes = int(int1DField % dimSizes(1), kind=I8KIND) * int_size + REPORT_FIELD_ALLOCATION(int1DField % fieldName, field_bytes) + allocate(int1DField % array(int1DField % dimSizes(1)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(int1DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) int1DField % array(:) = int1DField % defaultValue end if end if @@ -1717,7 +1829,18 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( int2DField % isPersistent ) then - allocate(int2DField % array(int2DField % dimSizes(1), int2DField % dimSizes(2))) + field_bytes = int(int2DField % dimSizes(1), kind=I8KIND) & + * int(int2DField % dimSizes(2), kind=I8KIND) & + * int_size + REPORT_FIELD_ALLOCATION(int2DField % fieldName, field_bytes) + allocate(int2DField % array(int2DField % dimSizes(1), int2DField % dimSizes(2)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(int2DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) int2DField % array(:,:) = int2DField % defaultValue end if end if @@ -1737,7 +1860,20 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( int3DField % isPersistent ) then - allocate(int3DField % array(int3DField % dimSizes(1), int3DField % dimSizes(2), int3DField % dimSizes(3))) + field_bytes = int(int3DField % dimSizes(1), kind=I8KIND) & + * int(int3DField % dimSizes(2), kind=I8KIND) & + * int(int3DField % dimSizes(3), kind=I8KIND) & + * int_size + REPORT_FIELD_ALLOCATION(int3DField % fieldName, field_bytes) + allocate(int3DField % array(int3DField % dimSizes(1), int3DField % dimSizes(2), & + int3DField % dimSizes(3)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(int3DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) int3DField % array(:,:,:) = int3DField % defaultValue end if end if @@ -1759,7 +1895,16 @@ recursive subroutine mpas_block_creator_allocate_pool_fields(currentPool, dimens end do if ( char1DField % isPersistent ) then - allocate(char1DField % array(char1DField % dimSizes(1))) + field_bytes = char1DField % dimSizes(1) + REPORT_FIELD_ALLOCATION(char1DField % fieldName, field_bytes) + allocate(char1DField % array(char1DField % dimSizes(1)), stat=ierr_alloc) + if (ierr_alloc /= 0) then + call mpas_log_write('failed to allocate '//trim(char1DField % fieldName), messageType=MPAS_LOG_ERR) + ierr = 1 + return + end if + allocated_bytes = allocated_bytes + field_bytes + REPORT_TOTAL_ALLOCATION(allocated_bytes) char1DField % array(:) = char1DField % defaultValue end if end if @@ -1785,4 +1930,50 @@ subroutine missing_dim_abort(dimName, fieldName) end subroutine missing_dim_abort + +!*********************************************************************** +! +! routine field_allocate_mesg +! +!> \brief Adds message to log file about memory to be allocated for a field +!> \author Michael Duda +!> \date 8 February 2022 +!> \details +!> Given the name of a field and the number of bytes to be allocated for that +!> field, write a message to the log file indicating that the specified number +!> of bytes will be allocated for the field. +! +!----------------------------------------------------------------------- + subroutine field_allocate_mesg(fieldName, field_bytes) + + character(len=*), intent(in) :: fieldName + integer(kind=I8KIND), intent(in) :: field_bytes + + call mpas_log_write(' allocating $i bytes for '//trim(fieldName), intArgs=[int(field_bytes)]) + + end subroutine field_allocate_mesg + + +!*********************************************************************** +! +! routine total_allocated_mesg +! +!> \brief Adds message to log file about total memory allocated for fields +!> \author Michael Duda +!> \date 8 February 2022 +!> \details +!> Given the the total number of bytes allocated as of the call to this routine, +!> write a message to the log file indicating the total number of kB that have +!> been allocated for fields. The allocated_bytes argument is measured in bytes, +!> and this value is internally converted to kB by this routine. +! +!----------------------------------------------------------------------- + subroutine total_allocated_mesg(allocated_bytes) + + integer(kind=I8KIND), intent(in) :: allocated_bytes + + call mpas_log_write(' total $i kB allocated on this task', intArgs=[int(allocated_bytes / 1000_I8KIND)]) + + end subroutine total_allocated_mesg + end module mpas_block_creator diff --git a/src/framework/mpas_block_decomp.F b/src/framework/mpas_block_decomp.F index 8a5c75ce9c..4f3d197d5d 100644 --- a/src/framework/mpas_block_decomp.F +++ b/src/framework/mpas_block_decomp.F @@ -98,7 +98,6 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l if (dminfo % my_proc_id == IO_NODE) then - iunit = 50 + dminfo % my_proc_id if (dminfo % total_blocks < 10) then write(filename,'(a,i1)') trim(blockFilePrefix), dminfo % total_blocks else if (dminfo % total_blocks < 100) then @@ -117,6 +116,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l write(filename,'(a,i8)') trim(blockFilePrefix), dminfo % total_blocks end if + call mpas_new_unit(iunit) open(unit=iunit, file=trim(filename), form='formatted', status='old', iostat=istatus) if (istatus /= 0) then @@ -194,6 +194,7 @@ subroutine mpas_block_decomp_cells_for_proc(dminfo, partial_global_graph_info, l global_start, local_nvertices, global_list, local_block_list) close(unit=iunit) + call mpas_release_unit(iunit) else @@ -661,7 +662,6 @@ subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ allocate(block_counter(dminfo % nProcs)) block_counter = 0 - iounit = 51 + dminfo % my_proc_id if (dminfo % nProcs < 10) then write(filename,'(a,i1)') trim(procFilePrefix), dminfo % nProcs else if (dminfo % nProcs < 100) then @@ -678,6 +678,7 @@ subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ write(filename,'(a,i7)') trim(procFilePrefix), dminfo % nProcs end if + call mpas_new_unit(iounit) open(unit=iounit, file=trim(filename), form='formatted', status='old', iostat=istatus) do i=1,dminfo % total_blocks @@ -690,6 +691,7 @@ subroutine mpas_build_block_proc_list(dminfo, procFilePrefix)!{{{ end do close(unit=iounit) + call mpas_release_unit(iounit) deallocate(block_counter) call mpas_dmpar_bcast_ints(dminfo, dminfo % total_blocks, dminfo % block_proc_list) call mpas_dmpar_bcast_ints(dminfo, dminfo % total_blocks, dminfo % block_local_id_list) diff --git a/src/framework/mpas_bootstrapping.F b/src/framework/mpas_bootstrapping.F index e87dadc077..b931bd6d95 100644 --- a/src/framework/mpas_bootstrapping.F +++ b/src/framework/mpas_bootstrapping.F @@ -76,13 +76,22 @@ module mpas_bootstrapping !> mpas_initialize_vectors() ! !----------------------------------------------------------------------- - subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype) !{{{ + subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype, pio_file_desc) !{{{ + +#ifdef MPAS_PIO_SUPPORT + use pio, only : file_desc_t +#endif implicit none type (domain_type), pointer :: domain character(len=*), intent(in) :: mesh_filename integer, intent(in) :: mesh_iotype +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, intent(inout), optional :: pio_file_desc +#endif type (block_type), pointer :: readingBlock @@ -147,7 +156,8 @@ subroutine mpas_bootstrap_framework_phase1(domain, mesh_filename, mesh_iotype) ! nHalos = config_num_halos - inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, mesh_iotype, domain % ioContext, ierr=ierr) + inputHandle = MPAS_io_open(trim(mesh_filename), MPAS_IO_READ, mesh_iotype, domain % ioContext, & + pio_file_desc=pio_file_desc, ierr=ierr) if (ierr /= MPAS_IO_NOERR) then call mpas_log_write('Could not open input file '''//trim(mesh_filename)//''' to read mesh fields', MPAS_LOG_CRIT) else @@ -437,14 +447,22 @@ end subroutine mpas_bootstrap_framework_phase1 !}}} !> and allocating all fields and structs. ! !----------------------------------------------------------------------- - subroutine mpas_bootstrap_framework_phase2(domain) !{{{ + subroutine mpas_bootstrap_framework_phase2(domain, pio_file_desc) !{{{ use mpas_stream_manager use mpas_stream_list +#ifdef MPAS_PIO_SUPPORT + use pio, only : file_desc_t +#endif implicit none type (domain_type), pointer :: domain +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, intent(inout), optional :: pio_file_desc +#endif type (mpas_pool_type), pointer :: readableDimensions type (mpas_pool_type), pointer :: streamDimensions @@ -474,105 +492,182 @@ subroutine mpas_bootstrap_framework_phase2(domain) !{{{ call mpas_log_write(' ') call mpas_log_write(' ') - ! Reading dimensions from streams - call mpas_log_write('Reading dimensions from input streams ...') - call mpas_stream_mgr_begin_iteration(domain % streamManager) - do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamID = streamName, directionProperty = streamDirection, & - activeProperty = streamActive) ) + if (present(pio_file_desc)) then + call mpas_log_write('Reading dimensions from external PIO file handle ...') + + ! Build stream dimension pool from the list of fields + call mpas_pool_create_pool(streamDimensions) - if ( streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + call mpas_pool_begin_iteration(domain % blocklist % allFields) + do while ( mpas_pool_get_next_member(domain % blocklist % allFields, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_FIELD ) then + call get_dimlist_for_field(domain % blocklist % allFields, poolItr % memberName, dimNames) + do i=1,size(dimNames) + call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) + if ( .not. associated(dimValue) ) then + call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) + end if + end do + end if + end do - call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=streamName) + ioType = MPAS_IO_NETCDF ! ioType is not actually used when an external PIO file_desc_t is provided to MPAS_io_open + inputHandle = MPAS_io_open('FILENAME_NOT_USED', MPAS_IO_READ, ioType, domain % ioContext, pio_file_desc = pio_file_desc, ierr = err_local) - ! Build stream dimension pool from the list of fields - call mpas_pool_create_pool(streamDimensions) + ! If to determine if file was opened or not. + if ( err_local == MPAS_IO_NOERR ) then - do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamName, fieldName, isActive=fieldActive) ) + call mpas_log_write(' ') - if (fieldActive) then - call get_dimlist_for_field(domain % blocklist % allFields, fieldName, dimNames) + ! Iterate over list of dimensions we determined we need from the above loop + call mpas_pool_begin_iteration(streamDimensions) + do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then + ! Try to read the dimension + call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + + ! Check to see if the dimension has already been defined + call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + + ! If to see if dimension was read or not + if ( err_local == MPAS_IO_NOERR ) then + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) - do i=1,size(dimNames) - call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) if ( .not. associated(dimValue) ) then - call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) + call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) + else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then + dimValue = tempDim + else if ( dimValue /= tempDim ) then + call mpas_log_write('Dimension ' // trim(poolItr % membername) & + // ' was read with an inconsistent value.', MPAS_LOG_CRIT) end if - end do - deallocate(dimNames) - end if + else + call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') + end if + end if end do - ! Determine stream filename - call mpas_get_stream_filename(domain % streamManager, streamID = streamName, filename = streamFilename, ierr = err_local) + ! Close file + call MPAS_io_close(inputHandle) - ! Determine stream io_type - call MPAS_stream_mgr_get_property(domain % streamManager, streamName, & - MPAS_STREAM_PROPERTY_IOTYPE, ioType, ierr = err_local) + end if - ! Try to open file - inputHandle = MPAS_io_open(trim(streamFilename), MPAS_IO_READ, ioType, domain % ioContext, ierr = err_local) + ! Destroy pool that contains list of streams dimensions + call mpas_pool_destroy_pool(streamDimensions) - ! If to determine if file was opened or not. - if ( err_local == MPAS_IO_NOERR ) then + else - call mpas_log_write(' ') - call mpas_log_write('----- reading dimensions from stream '''//trim(streamName)//''' using file ' & - //trim(streamFilename) ) + ! Reading dimensions from streams + call mpas_log_write('Reading dimensions from input streams ...') + call mpas_stream_mgr_begin_iteration(domain % streamManager) + do while ( mpas_stream_mgr_get_next_stream(domain % streamManager, streamID = streamName, directionProperty = streamDirection, & + activeProperty = streamActive) ) - ! Iterate over list of dimensions we determined we need from the above loop - call mpas_pool_begin_iteration(streamDimensions) - do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) - if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then - ! Try to read the dimension - call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + if ( streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then - ! Check to see if the dimension has already been defined - call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + call mpas_stream_mgr_begin_iteration(domain % streamManager, streamID=streamName) - ! If to see if dimension was read or not - if ( err_local == MPAS_IO_NOERR ) then - call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) + ! Build stream dimension pool from the list of fields + call mpas_pool_create_pool(streamDimensions) + do while ( mpas_stream_mgr_get_next_field(domain % streamManager, streamName, fieldName, isActive=fieldActive) ) + + if (fieldActive) then + call get_dimlist_for_field(domain % blocklist % allFields, fieldName, dimNames) + + do i=1,size(dimNames) + call mpas_pool_get_dimension(streamDimensions, dimNames(i), dimValue) if ( .not. associated(dimValue) ) then - call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) - else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then - dimValue = tempDim - else if ( dimValue /= tempDim ) then - call mpas_log_write('Dimension ' // trim(poolItr % membername) & - // ' was read with an inconsistent value.', MPAS_LOG_CRIT) + call mpas_pool_add_dimension(streamDimensions, dimNames(i), MPAS_MISSING_DIM) end if - else - call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') - end if - + end do + deallocate(dimNames) end if + end do - ! Close file - call mpas_io_close(inputHandle) - else - call mpas_log_write(' ') - call mpas_log_write(' *** unable to open input file '//trim(streamFilename)//' for stream ''' & - //trim(streamName)//'''') - end if + ! Determine stream filename + call mpas_get_stream_filename(domain % streamManager, streamID = streamName, filename = streamFilename, ierr = err_local) - ! Destroy pool that contains list of streams dimensions - call mpas_pool_destroy_pool(streamDimensions) + ! Determine stream io_type + call MPAS_stream_mgr_get_property(domain % streamManager, streamName, & + MPAS_STREAM_PROPERTY_IOTYPE, ioType, ierr = err_local) - else if ( .not. streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + ! Try to open file + inputHandle = MPAS_io_open(trim(streamFilename), MPAS_IO_READ, ioType, domain % ioContext, ierr = err_local) + + ! If to determine if file was opened or not. + if ( err_local == MPAS_IO_NOERR ) then + + call mpas_log_write(' ') + call mpas_log_write('----- reading dimensions from stream '''//trim(streamName)//''' using file ' & + //trim(streamFilename) ) + + ! Iterate over list of dimensions we determined we need from the above loop + call mpas_pool_begin_iteration(streamDimensions) + do while ( mpas_pool_get_next_member(streamDimensions, poolItr) ) + if ( poolItr % memberType == MPAS_POOL_DIMENSION ) then + ! Try to read the dimension + call mpas_io_inq_dim(inputHandle, trim(poolItr % memberName), tempDim, ierr = err_local) + + ! Check to see if the dimension has already been defined + call mpas_pool_get_dimension(readableDimensions, poolItr % memberName, dimValue) + + ! If to see if dimension was read or not + if ( err_local == MPAS_IO_NOERR ) then + call mpas_log_write(' ' // trim(poolItr % memberName) // ' = $i', intArgs=(/tempDim/) ) + + if ( .not. associated(dimValue) ) then + call mpas_pool_add_dimension(readableDimensions, poolItr % memberName, tempDim) + else if ( dimValue /= tempDim .and. dimValue == MPAS_MISSING_DIM ) then + dimValue = tempDim + else if ( dimValue /= tempDim ) then + call mpas_log_write('Dimension ' // trim(poolItr % membername) & + // ' was read with an inconsistent value.', MPAS_LOG_CRIT) + end if + else + call mpas_log_write(' ' // trim(poolItr % memberName) // ' *** not found in stream ***') + call mpas_log_write('') + call mpas_log_write("At least one fields to be read from the '" // trim(streamName) & + // "' stream is dimensioned", messageType=MPAS_LOG_ERR) + call mpas_log_write("by '" // trim(poolItr % memberName) // "', but the '" & + // trim(poolItr % memberName) // "' dimension is not defined", & + messageType=MPAS_LOG_ERR) + call mpas_log_write('in the file '//trim(streamFilename), messageType=MPAS_LOG_ERR) + call mpas_log_write("Please check the input file(s) to be read by the '" // trim(streamName) & + // "' input stream.", messageType=MPAS_LOG_CRIT) + end if - call mpas_log_write(' ') - call mpas_log_write('----- skipping inactive stream '''//trim(streamName)//'''') + end if + end do + + ! Close file + call mpas_io_close(inputHandle) + else + call mpas_log_write(' ') + call mpas_log_write(' *** unable to open input file '//trim(streamFilename)//' for stream ''' & + //trim(streamName)//'''') + end if + + ! Destroy pool that contains list of streams dimensions + call mpas_pool_destroy_pool(streamDimensions) + + else if ( .not. streamActive .and. ( streamDirection == MPAS_STREAM_INPUT .or. streamDirection == MPAS_STREAM_INPUT_OUTPUT ) ) then + + call mpas_log_write(' ') + call mpas_log_write('----- skipping inactive stream '''//trim(streamName)//'''') - end if + end if - end do + end do - call mpas_log_write(' ') - call mpas_log_write('----- done reading dimensions from input streams -----') - call mpas_log_write(' ') - call mpas_log_write(' ') + call mpas_log_write(' ') + call mpas_log_write('----- done reading dimensions from input streams -----') + call mpas_log_write(' ') + call mpas_log_write(' ') + + end if call mpas_pool_set_error_level(err_level) diff --git a/src/framework/mpas_c_interfacing.F b/src/framework/mpas_c_interfacing.F index dd885600f4..f6dc97edc5 100644 --- a/src/framework/mpas_c_interfacing.F +++ b/src/framework/mpas_c_interfacing.F @@ -4,6 +4,37 @@ module mpas_c_interfacing contains + !----------------------------------------------------------------------- + ! routine mpas_sanitize_string + ! + !> \brief Converts C null characters in a Fortran string to spaces + !> \author Michael Duda + !> \date 19 February 2019 + !> \details + !> Converts all C null characters in a Fortran string to spaces. + !> This may be useful for strings that were provided by C code through other + !> Fortran code external to MPAS. + ! + !----------------------------------------------------------------------- + subroutine mpas_sanitize_string(str) + + use iso_c_binding, only : c_null_char + + implicit none + + character(len=*), intent(inout) :: str + + integer :: i + + do i=1,len(str) + if (str(i:i) == c_null_char) then + str(i:i) = ' ' + end if + end do + + end subroutine mpas_sanitize_string + + !----------------------------------------------------------------------- ! routine mpas_c_to_f_string ! diff --git a/src/framework/mpas_constants.F b/src/framework/mpas_constants.F index 1eec5d3565..c98cb8102b 100644 --- a/src/framework/mpas_constants.F +++ b/src/framework/mpas_constants.F @@ -22,35 +22,72 @@ module mpas_constants use mpas_kind_types - real (kind=RKIND), parameter :: pii = 3.141592653589793 !< Constant: Pi - real (kind=RKIND), parameter :: a = 6371229.0 !< Constant: Spherical Earth radius [m] - real (kind=RKIND), parameter :: omega = 7.29212e-5 !< Constant: Angular rotation rate of the Earth [s-1] - real (kind=RKIND), parameter :: gravity = 9.80616 !< Constant: Acceleration due to gravity [m s-2] - real (kind=RKIND), parameter :: rgas = 287.0 !< Constant: Gas constant for dry air [J kg-1 K-1] - real (kind=RKIND), parameter :: rv = 461.6 !< Constant: Gas constant for water vapor [J kg-1 K-1] - real (kind=RKIND), parameter :: rvord = rv/rgas ! -! real (kind=RKIND), parameter :: cp = 1003.0 !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] - real (kind=RKIND), parameter :: cp = 7.*rgas/2. !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] - real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1] - real (kind=RKIND), parameter :: cvpm = -cv/cp ! - real (kind=RKIND), parameter :: prandtl = 1.0 !< Constant: Prandtl number +#ifdef MPAS_CAM_DYCORE + use physconst, only : pii => pi + use physconst, only : gravity => gravit + use physconst, only : omega + use physconst, only : a => rearth + use physconst, only : cp => cpair + use physconst, only : rgas => rair + use physconst, only : rv => rh2o + real (kind=RKIND) :: rvord = huge(1.0_RKIND) ! Derived in mpas_constants_compute_derived + real (kind=RKIND) :: cv = huge(1.0_RKIND) ! Derived in mpas_constants_compute_derived + real (kind=RKIND) :: cvpm = huge(1.0_RKIND) ! Derived in mpas_constants_compute_derived +#else + real (kind=RKIND), parameter :: pii = 3.141592653589793_RKIND !< Constant: Pi + real (kind=RKIND), parameter :: a = 6371229.0_RKIND !< Constant: Spherical Earth radius [m] + real (kind=RKIND), parameter :: omega = 7.29212e-5_RKIND !< Constant: Angular rotation rate of the Earth [s-1] + real (kind=RKIND), parameter :: gravity = 9.80616_RKIND !< Constant: Acceleration due to gravity [m s-2] + real (kind=RKIND), parameter :: rgas = 287.0_RKIND !< Constant: Gas constant for dry air [J kg-1 K-1] + real (kind=RKIND), parameter :: rv = 461.6_RKIND !< Constant: Gas constant for water vapor [J kg-1 K-1] +! real (kind=RKIND), parameter :: cp = 1003.0_RKIND !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] + real (kind=RKIND), parameter :: cp = 7.0_RKIND*rgas/2.0_RKIND !< Constant: Specific heat of dry air at constant pressure [J kg-1 K-1] + real (kind=RKIND), parameter :: rvord = rv / rgas ! + real (kind=RKIND), parameter :: cv = cp - rgas !< Constant: Specific heat of dry air at constant volume [J kg-1 K-1] + real (kind=RKIND), parameter :: cvpm = -cv / cp ! +#endif + real (kind=RKIND), parameter :: p0 = 1.0e5_RKIND !< Constant: 100000 Pa + real (kind=RKIND), parameter :: prandtl = 1.0_RKIND !< Constant: Prandtl number contains !*********************************************************************** ! -! routine dummy +! mpas_constants_compute_derived ! -!> \brief MPAS Dummy Routine +!> \brief Computes derived constants !> \author Michael Duda -!> \date 03/27/13 +!> \date 8 May 2020 !> \details -!> This is a dummy routine that doesn't do anything. +!> This routine provides a place where physical constants provided by +!> the mpas_constants module may be computed at runtime. For example, +!> if some constants depend on namelist options or other runtime +!> settings, other constants that derive from them may be computed in +!> this routine. +!> +!> At present, the MPAS infrastructure does not call this routine, and +!> it is the responsibility of any MPAS core that needs to compute +!> derived constants at runtime to add calls to this routine, e.g., in +!> its core_init routine. ! !----------------------------------------------------------------------- - subroutine dummy() + subroutine mpas_constants_compute_derived() + + implicit none + +#ifdef MPAS_CAM_DYCORE + ! + ! In the case of CAM-MPAS, rgas may depend on a CAM namelist option, + ! so physical constants that depend on rgas must be computed here after + ! CAM has called the physconst_readnl routine. + ! + + rvord = rv / rgas + cv = cp - rgas + cvpm = -cv / cp +#endif - end subroutine dummy + end subroutine mpas_constants_compute_derived end module mpas_constants diff --git a/src/framework/mpas_core_types.inc b/src/framework/mpas_core_types.inc index df5ede54ab..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_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 @@ -64,12 +68,13 @@ end interface abstract interface - function mpas_setup_log_function(logInfo, domain) result(iErr) + function mpas_setup_log_function(logInfo, domain, unitNumbers) result(iErr) import mpas_log_type import domain_type type (mpas_log_type), pointer, intent(inout) :: logInfo type (domain_type), pointer, intent(in) :: domain + integer, dimension(2), intent(in), optional :: unitNumbers integer :: iErr end function mpas_setup_log_function end interface @@ -105,15 +110,15 @@ abstract interface function mpas_setup_decomposed_dimensions_function(block, streamManager, readDimensions, dimensionPool, totalBlocks) result(iErr) - import block_type - import mpas_streamManager_type + import block_type + import mpas_streamManager_type import mpas_pool_type - type (block_type), intent(inout) :: block - type (mpas_streamManager_type), intent(inout) :: streamManager + type (block_type), intent(inout) :: block + type (mpas_streamManager_type), intent(inout) :: streamManager type (mpas_pool_type), intent(inout) :: readDimensions type (mpas_pool_type), intent(inout) :: dimensionPool - integer, intent(in) :: totalBlocks + integer, intent(in) :: totalBlocks integer :: iErr end function mpas_setup_decomposed_dimensions_function end interface @@ -151,6 +156,7 @@ character (len=StrKIND) :: modelVersion !< Constant: Version number character (len=StrKIND) :: executableName !< Constant: Name of executable generated at build time. character (len=StrKIND) :: git_version !< Constant: Version string from git-describe. + character (len=StrKIND) :: build_target !< Constant: Build target from top-level Makefile. character (len=StrKIND*2) :: history !< History attribute, read in from input file. character (len=StrKIND) :: Conventions !< Conventions attribute, read in from input file. character (len=StrKIND) :: source !< source attribute, read in from input file. diff --git a/src/framework/mpas_derived_types.F b/src/framework/mpas_derived_types.F index 9404093daa..9995fd147e 100644 --- a/src/framework/mpas_derived_types.F +++ b/src/framework/mpas_derived_types.F @@ -25,18 +25,24 @@ !----------------------------------------------------------------------- module mpas_derived_types + use iso_c_binding, only : c_ptr, c_null_ptr + use mpas_kind_types +#ifdef MPAS_PIO_SUPPORT use pio use pio_types +#endif + +#ifdef MPAS_SMIOL_SUPPORT + 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 - use ESMF_BaseMod - use ESMF_Stubs - use ESMF_CalendarMod - use ESMF_ClockMod - use ESMF_TimeMod - use ESMF_TimeIntervalMod #include "mpas_attlist_types.inc" @@ -46,6 +52,8 @@ module mpas_derived_types #include "mpas_field_types.inc" +#include "mpas_halo_types.inc" + #include "mpas_pool_types.inc" #include "mpas_particle_list_types.inc" @@ -68,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 490687d095..6d68c0c656 100644 --- a/src/framework/mpas_dmpar.F +++ b/src/framework/mpas_dmpar.F @@ -31,8 +31,21 @@ module mpas_dmpar #ifdef _MPI #ifndef NOMPIMOD +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Comm, MPI_Datatype + use mpi_f08, only : MPI_INTEGER, MPI_2INTEGER, MPI_REAL, MPI_2REAL, MPI_DOUBLE_PRECISION, & + MPI_2DOUBLE_PRECISION, MPI_CHARACTER, MPI_INTEGER8 + use mpi_f08, only : MPI_COMM_SELF, MPI_COMM_WORLD, MPI_INFO_NULL, MPI_THREAD_SINGLE, & + MPI_THREAD_SERIALIZED, MPI_THREAD_FUNNELED, MPI_THREAD_MULTIPLE, MPI_STATUS_IGNORE + use mpi_f08, only : MPI_Query_thread, MPI_Comm_dup + use mpi_f08, only : MPI_Init_thread , MPI_Init, MPI_Comm_rank, MPI_Comm_size, MPI_Finalize, & + MPI_Comm_free, MPI_Abort, MPI_Bcast, MPI_Allreduce, MPI_Scatterv, MPI_Recv, & + MPI_Send, MPI_Request, MPI_Irecv, MPI_Isend, MPI_Wait, MPI_Wtime, MPI_Test + use mpi_f08, only : MPI_SUM, MPI_MIN, MPI_MAX, MPI_MINLOC, MPI_MAXLOC +#else use mpi #endif +#endif #endif implicit none @@ -42,16 +55,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 @@ -70,12 +98,14 @@ module mpas_dmpar public :: mpas_dmpar_bcast_ints public :: mpas_dmpar_bcast_real public :: mpas_dmpar_bcast_reals + public :: mpas_dmpar_bcast_real4s public :: mpas_dmpar_bcast_double public :: mpas_dmpar_bcast_doubles public :: mpas_dmpar_bcast_logical 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 @@ -150,6 +180,14 @@ module mpas_dmpar module procedure mpas_dmpar_exch_halo_field5d_real end interface + interface mpas_dmpar_exch_halo_adj_field + module procedure mpas_dmpar_exch_halo_adj_field2d_real + end interface + + public :: mpas_dmpar_exch_halo_adj_field + + private :: mpas_dmpar_exch_halo_adj_field2d_real + public :: mpas_dmpar_exch_halo_field private :: mpas_dmpar_exch_halo_field1d_integer @@ -231,12 +269,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 +287,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 @@ -510,6 +552,46 @@ subroutine mpas_dmpar_bcast_reals(dminfo, n, rarray, proc)!{{{ end subroutine mpas_dmpar_bcast_reals!}}} +!----------------------------------------------------------------------- +! routine mpas_dmpar_bcast_real4s +! +!> \brief MPAS dmpar broadcast R4KIND routine. +!> \author Michael Duda, William Lipscomb +!> \date 8 July 2024 +!> \details +!> This routine broadcasts an array of R4KIND reals to all processors in +!> the communicator. An optional argument specifies the source node; else +!> broadcast from IO_NODE. +! +!----------------------------------------------------------------------- + subroutine mpas_dmpar_bcast_real4s(dminfo, n, rarray, proc)!{{{ + + implicit none + + type (dm_info), intent(in) :: dminfo !< Input: Domain information + integer, intent(in) :: n !< Input: Length of array + real (kind=R4KIND), dimension(n), intent(inout) :: rarray !< Input/Output: Array of reals to be broadcast + integer, intent(in), optional :: proc !< optional argument indicating which processor to broadcast from + +#ifdef _MPI + integer :: mpi_ierr, source + integer :: threadNum + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + if (present(proc)) then + source = proc + else + source = IO_NODE + endif + + call MPI_Bcast(rarray, n, MPI_REAL, source, dminfo % comm, mpi_ierr) + end if +#endif + + end subroutine mpas_dmpar_bcast_real4s!}}} + !----------------------------------------------------------------------- ! routine mpas_dmpar_bcast_double ! @@ -750,6 +832,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 +1621,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 @@ -5424,6 +5544,7 @@ subroutine mpas_dmpar_exch_halo_field2d_real(field, haloLayersIn)!{{{ end do else nHaloLayers = size(field % sendList % halos) + DMPAR_DEBUG_WRITE('exch_halo nHaloLayers:$i destList halos:$i' COMMA intArgs=(/nHaloLayers COMMA size(field%recvList%halos)/)) allocate(haloLayers(nHaloLayers)) do iHalo = 1, nHaloLayers haloLayers(iHalo) = iHalo @@ -6133,6 +6254,193 @@ subroutine mpas_dmpar_exch_halo_field5d_real(field, haloLayersIn)!{{{ end subroutine mpas_dmpar_exch_halo_field5d_real!}}} + !----------------------------------------------------------------------- + ! routine mpas_dmpar_exch_halo_adj_field2d_real + ! + !> \brief MPAS dmpar halo exchange adjoint 2D real field + !> \author BJ Jung + !> \date 09/2020 + !> \details + !> This routine handles the adjoint of halo exchange communication of an input field across all processors. + !> It accumulates the values of owned point with the values of halos. It is based on mpas_dmpar_exch_halo_field2d_real. + !> + !> Note the number of halo layers impacts the number of cells which will be updated by this routine: + !> The first halo layer will update the owned 'edge' cells, where 'edge' cells are adjacent to ghost cells. + !> The second halo layer will update owned cells which are adjacent to the 'edge' cells. + !> The third halo layer will update owned cells which are adjacent to the cells updated by the seconds halo layer, etc. + !----------------------------------------------------------------------- + subroutine mpas_dmpar_exch_halo_adj_field2d_real(field, haloLayersIn)!{{{ + + implicit none + + type (field2dReal), pointer, intent(inout) :: field !< Input: Field to communicate + integer, dimension(:), intent(in), optional :: haloLayersIn !< Input: List of halo layers to communicate. Defaults to all + type (dm_info), pointer :: dminfo + type (field2dReal), pointer :: fieldCursor, fieldCursor2 + type (mpas_exchange_list), pointer :: exchListPtr + type (mpas_communication_list), pointer :: sendList, recvList, commListPtr + integer :: mpi_ierr, threadNum + integer :: nHaloLayers, iHalo, i, j + integer :: bufferOffset, nAdded + integer, dimension(:), pointer :: haloLayers + + if ( .not. field % isActive ) then + DMPAR_DEBUG_WRITE(' -- Skipping halo exchange for deactivated field: ' // trim(field % fieldName)) + return + end if + + do i = 1, 2 + if(field % dimSizes(i) <= 0) then + return + end if + end do + + dminfo => field % block % domain % dminfo + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + if(present(haloLayersIn)) then + nHaloLayers = size(haloLayersIn) + allocate(haloLayers(nHaloLayers)) + do iHalo = 1, nHaloLayers + haloLayers(iHalo) = haloLayersIn(iHalo) + end do + else + nHaloLayers = size(field % sendList % halos) + DMPAR_DEBUG_WRITE('exch_halo_adjoint nHaloLayers:$i destList halos:$i' COMMA intArgs=(/nHaloLayers COMMA size(field%recvList%halos)/)) + allocate(haloLayers(nHaloLayers)) + do iHalo = 1, nHaloLayers + haloLayers(iHalo) = iHalo + end do + end if + +#ifdef _MPI + ! Setup Communication Lists + call mpas_dmpar_build_comm_lists(field % sendList, field % recvList, haloLayers, field % dimsizes, sendList, recvList) + + ! Allocate space in recv lists, and initiate mpi_irecv calls + commListPtr => sendList + do while(associated(commListPtr)) + allocate(commListPtr % rbuffer(commListPtr % nList)) + nullify(commListPtr % ibuffer) + call MPI_Irecv(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, commListPtr % procID, dminfo % comm, commListPtr % reqID, mpi_ierr) + + commListPtr => commListPtr % next + end do + + ! Allocate space in send lists, copy data into buffer, and initiate mpi_isend calls + commListPtr => recvList + do while(associated(commListPtr)) + allocate(commListPtr % rbuffer(commListPtr % nList)) + nullify(commListPtr % ibuffer) + bufferOffset = 0 + do iHalo = 1, nHaloLayers + nAdded = 0 + fieldCursor => field + do while(associated(fieldCursor)) + exchListPtr => fieldCursor % recvList % halos(haloLayers(iHalo)) % exchList + do while(associated(exchListPtr)) + if(exchListPtr % endPointID == commListPtr % procID) then + do i = 1, exchListPtr % nList + do j = 1, fieldCursor % dimSizes(1) + commListPtr % rbuffer((exchListPtr % srcList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) = fieldCursor % array(j, exchListPtr % destList(i)) + ! update halo cell + fieldCursor % array(j, exchListPtr % destList(i)) = 0.0_RKIND + nAdded = nAdded + 1 + end do + end do + end if + + exchListPtr => exchListPtr % next + end do + + fieldCursor => fieldCursor % next + end do + bufferOffset = bufferOffset + nAdded + end do + + call MPI_Isend(commListPtr % rbuffer, commListPtr % nList, MPI_REALKIND, commListPtr % procID, dminfo % my_proc_id, dminfo % comm, commListPtr % reqID, mpi_ierr) + commListPtr => commListPtr % next + end do +#endif + + ! Handle local copy. If MPI is off, then only local copies are performed. + fieldCursor => field + do while(associated(fieldCursor)) + do iHalo = 1, nHaloLayers + exchListPtr => fieldCursor % copyList % halos(haloLayers(iHalo)) % exchList + + do while(associated(exchListPtr)) + fieldCursor2 => field + do while(associated(fieldCursor2)) + if(exchListPtr % endPointID == fieldCursor2 % block % localBlockID) then + do i = 1, exchListPtr % nList + !fieldCursor2 % array(:, exchListPtr % destList(i)) = fieldCursor % array(:, exchListPtr % srcList(i)) + fieldCursor % array(:, exchListPtr % srcList(i)) = fieldCursor % array(:, exchListPtr % srcList(i)) + fieldCursor2 % array(:, exchListPtr % destList(i)) + fieldCursor2 % array(:, exchListPtr % destList(i)) = 0.0_RKIND + end do + end if + + fieldCursor2 => fieldCursor2 % next + end do + + exchListPtr => exchListPtr % next + end do + end do + + fieldCursor => fieldCursor % next + end do + +#ifdef _MPI + + ! Wait for mpi_irecv to finish, and unpack data from buffer + commListPtr => sendList + do while(associated(commListPtr)) + call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr) + bufferOffset = 0 + do iHalo = 1, nHaloLayers + nAdded = 0 + fieldCursor => field + do while(associated(fieldCursor)) + exchListPtr => fieldCursor % sendList % halos(haloLayers(iHalo)) % exchList + do while(associated(exchListPtr)) + if(exchListPtr % endPointID == commListPtr % procID) then + do i = 1, exchListPtr % nList + do j = 1, fieldCursor % dimSizes(1) + ! update cell in our block + fieldCursor % array(j, exchListPtr % srcList(i)) = fieldCursor % array(j, exchListPtr % srcList(i)) + commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) + commListPtr % rbuffer((exchListPtr % destList(i)-1) * fieldCursor % dimSizes(1) + j + bufferOffset) = 0.0_RKIND + end do + end do + nAdded = max(nAdded, maxval(exchListPtr % destList) * fieldCursor % dimSizes(1)) + end if + exchListPtr => exchListPtr % next + end do + + fieldCursor => fieldCursor % next + end do + bufferOffset = bufferOffset + nAdded + end do + commListPtr => commListPtr % next + end do + + ! wait for mpi_isend to finish. + commListPtr => recvList + do while(associated(commListPtr)) + call MPI_Wait(commListPtr % reqID, MPI_STATUS_IGNORE, mpi_ierr) + commListPtr => commListPtr % next + end do + + ! Destroy commLists. + call mpas_dmpar_destroy_communication_list(sendList) + call mpas_dmpar_destroy_communication_list(recvList) +#endif + + deallocate(haloLayers) + end if + + end subroutine mpas_dmpar_exch_halo_adj_field2d_real!}}} + !----------------------------------------------------------------------- ! routine mpas_dmpar_init_multihalo_exchange_list ! @@ -8463,7 +8771,12 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field1d_integer(exchangeGroup, fiel commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + ! workaround for PGI compiler (CPR): ICE on pointers in private clause of omp-do workshare + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8528,7 +8841,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field2d_integer(exchangeGroup, fiel commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8596,7 +8913,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field3d_integer(exchangeGroup, fiel commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8666,7 +8987,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field1d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8731,7 +9056,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field2d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8798,7 +9127,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field3d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8868,7 +9201,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field4d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, l, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -8941,7 +9278,11 @@ subroutine mpas_dmpar_exch_group_pack_buffer_field5d_real(exchangeGroup, field, commListPtr => exchangeGroup % sendList if (.not. associated(commListPtr)) return commListSize = commListPtr % commListSize +#ifdef CPRPGI + !$omp do private(listPosition, bufferOffset, nAdded, iExch, iBuffer) +#else !$omp do private(commListPtr, listPosition, bufferOffset, nAdded, fieldCursor, exchListPtr, iExch, j, k, l, m, iBuffer) +#endif do listItem = 1, commListSize commListPtr => exchangeGroup % sendList do listPosition = 2, listItem @@ -10006,7 +10347,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 ) /) ) @@ -10025,7 +10370,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 0bea339e52..7a9d400e73 100644 --- a/src/framework/mpas_domain_types.inc +++ b/src/framework/mpas_domain_types.inc @@ -9,12 +9,18 @@ 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 ! Store exchange group information here type (mpas_exchange_group), pointer :: exchangeGroups => null() + ! Storage for halo exchange groups + type (mpas_pool_type), pointer :: haloGroupPool => null() ! Only used internally by mpas_halo module + type (mpas_halo_group), pointer :: haloGroups => null() ! Head pointer of linked list of halo groups + ! Domain specific constants logical :: on_a_sphere = .true. logical :: is_periodic = .false. @@ -26,6 +32,9 @@ character (len=StrKIND) :: mesh_spec = '' !< mesh_spec attribute, read in from input file. character (len=StrKIND) :: parent_id = '' !< parent_id attribute, read in from input file. + ! Unique global ID number for this domain + integer :: domainID + ! Pointer to timer root type (mpas_timer_root), pointer :: timer_root => null() diff --git a/src/framework/mpas_field_accessor.F b/src/framework/mpas_field_accessor.F deleted file mode 100644 index 67aad7f53c..0000000000 --- a/src/framework/mpas_field_accessor.F +++ /dev/null @@ -1,293 +0,0 @@ -! Copyright (c) 2013, Los Alamos National Security, LLC (LANS) -! and 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 -! - -#define COMMA , -#define ACCESSOR_ERROR_WRITE(M) call mpas_log_write( M , messageType=MPAS_LOG_ERR) - -!*********************************************************************** -! -! mpas_field_accessor -! -!> \brief Module providing quick access to members of fields by name -!> \author Michael Duda, Doug Jacobsen -!> \date 28 March 2016 -!> \details -!> This module provides routines for accessing members of field types -!> (e.g., missingValue) given only the name of the field and a pool -!> in which the field may be found. -! -!----------------------------------------------------------------------- -module mpas_field_accessor - - use mpas_derived_types, only : mpas_pool_type, mpas_pool_field_info_type, & - MPAS_POOL_REAL, MPAS_POOL_INTEGER, MPAS_POOL_CHARACTER, MPAS_POOL_LOGICAL, & - field0DReal, field1DReal, field2DReal, field3DReal, field4DReal, field5DReal, & - field0DInteger, field1DInteger, field2DInteger, field3DInteger, & - field0DChar, field1DChar, & - field0DLogical, & - MPAS_LOG_ERR - use mpas_kind_types, only : RKIND, StrKIND - use mpas_pool_routines, only : mpas_pool_get_field_info, mpas_pool_get_field - use mpas_log - - interface mpas_field_access_missing_value - module procedure mpas_field_access_msgval_real - module procedure mpas_field_access_msgval_int - module procedure mpas_field_access_msgval_char - module procedure mpas_field_access_msgval_logical - end interface mpas_field_access_missing_value - - - contains - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_real(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - real(kind=RKIND), intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DReal), pointer :: r0 => null() - type (field1DReal), pointer :: r1 => null() - type (field2DReal), pointer :: r2 => null() - type (field3DReal), pointer :: r3 => null() - type (field4DReal), pointer :: r4 => null() - type (field5DReal), pointer :: r5 => null() - - - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_REAL - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_REAL) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not a real-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is a real-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), r0) - missingValue = r0 % missingValue - case (1) - call mpas_pool_get_field(fieldPool, trim(fieldName), r1) - missingValue = r1 % missingValue - case (2) - call mpas_pool_get_field(fieldPool, trim(fieldName), r2) - missingValue = r2 % missingValue - case (3) - call mpas_pool_get_field(fieldPool, trim(fieldName), r3) - missingValue = r3 % missingValue - case (4) - call mpas_pool_get_field(fieldPool, trim(fieldName), r4) - missingValue = r4 % missingValue - case (5) - call mpas_pool_get_field(fieldPool, trim(fieldName), r5) - missingValue = r5 % missingValue - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (6-d or more) in mpas_field_access_msgval_real') - end select - - end subroutine mpas_field_access_msgval_real - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_int(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - integer, intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DInteger), pointer :: i0 => null() - type (field1DInteger), pointer :: i1 => null() - type (field2DInteger), pointer :: i2 => null() - type (field3DInteger), pointer :: i3 => null() - - - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_INTEGER - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_INTEGER) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not an integer-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is an integer-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), i0) - missingValue = i0 % missingValue - case (1) - call mpas_pool_get_field(fieldPool, trim(fieldName), i1) - missingValue = i1 % missingValue - case (2) - call mpas_pool_get_field(fieldPool, trim(fieldName), i2) - missingValue = i2 % missingValue - case (3) - call mpas_pool_get_field(fieldPool, trim(fieldName), i3) - missingValue = i3 % missingValue - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (4-d or more) in mpas_field_access_msgval_int') - end select - - end subroutine mpas_field_access_msgval_int - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_char(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - character(len=*), intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DChar), pointer :: c0 => null() - type (field1DChar), pointer :: c1 => null() - - - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_CHARACTER - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_CHARACTER) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not a char-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is a character-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), c0) - if (len(missingValue) < len_trim(c0 % missingValue)) then - ACCESSOR_ERROR_WRITE('Truncating missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Actual argument for missingValue is too short') - missingValue = c0 % missingValue(1:len(missingValue)) - else - missingValue = trim(c0 % missingValue) - end if - case (1) - call mpas_pool_get_field(fieldPool, trim(fieldName), c1) - if (len(missingValue) < len_trim(c1 % missingValue)) then - ACCESSOR_ERROR_WRITE('Truncating missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Actual argument for missingValue is too short') - missingValue = c1 % missingValue(1:len(missingValue)) - else - missingValue = trim(c1 % missingValue) - end if - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (2-d or more) in mpas_field_access_msgval_char') - end select - - end subroutine mpas_field_access_msgval_char - - - !----------------------------------------------------------------------- - ! subroutine mpas_field_access_missing_value - ! - !> \brief Accesses the 'missingValue' member for a field given the field name - !> \author Doug Jacobsen, Michael Duda - !> \date 28 March 2016 - !> \details - !> This routine returns the value of the 'missingValue' member from the field type - !> for the specified field. The named field must exist in the specified pool; - !> if it does not, an error message will be printed. - ! - !----------------------------------------------------------------------- - subroutine mpas_field_access_msgval_logical(fieldPool, fieldName, missingValue) - - implicit none - - type (mpas_pool_type), intent(in) :: fieldPool - character(len=*), intent(in) :: fieldName - logical, intent(out) :: missingValue - - type (mpas_pool_field_info_type) :: fieldInfo - type (field0DLogical), pointer :: l0 => null() - - -#ifdef POOL_LOGICAL_FIELD_SUPPORT - ! Initialize fieldType so we can detect whether returned info is valid - fieldInfo % fieldType = MPAS_POOL_LOGICAL - 1 - call mpas_pool_get_field_info(fieldPool, trim(fieldName), fieldInfo) - - if (fieldInfo % fieldType /= MPAS_POOL_LOGICAL) then - ACCESSOR_ERROR_WRITE('Cannot return missingValue for field '//trim(fieldName)) - ACCESSOR_ERROR_WRITE('Either '//trim(fieldName)//' was not found in the specified pool or is not a logical-type field') - return - end if - - ! At this point, we know that the field exists in the pool and is a logical-valued field, - ! so we should not need extensive error checking below... - - select case(fieldInfo % nDims) - case (0) - call mpas_pool_get_field(fieldPool, trim(fieldName), l0) - missingValue = l0 % missingValue - case default - ACCESSOR_ERROR_WRITE('Unhandled dimensionality (1-d or more) in mpas_field_access_msgval_logical') - end select -#else - ACCESSOR_ERROR_WRITE('Support for accessing missingValue for logical fields is not implemented') -#endif - - end subroutine mpas_field_access_msgval_logical - - -end module mpas_field_accessor diff --git a/src/framework/mpas_field_routines.F b/src/framework/mpas_field_routines.F index a5f6960749..0ae6e169e8 100644 --- a/src/framework/mpas_field_routines.F +++ b/src/framework/mpas_field_routines.F @@ -108,6 +108,22 @@ module mpas_field_routines module procedure mpas_deallocate_field1d_char end interface + interface mpas_deallocate_field_target + module procedure mpas_deallocate_field0d_logical_target + module procedure mpas_deallocate_field0d_integer_target + module procedure mpas_deallocate_field1d_integer_target + module procedure mpas_deallocate_field2d_integer_target + module procedure mpas_deallocate_field3d_integer_target + module procedure mpas_deallocate_field0d_real_target + module procedure mpas_deallocate_field1d_real_target + module procedure mpas_deallocate_field2d_real_target + module procedure mpas_deallocate_field3d_real_target + module procedure mpas_deallocate_field4d_real_target + module procedure mpas_deallocate_field5d_real_target + module procedure mpas_deallocate_field0d_char_target + module procedure mpas_deallocate_field1d_char_target + end interface + contains !*********************************************************************** @@ -1388,43 +1404,39 @@ end subroutine mpas_deallocate_scratch_field1d_char!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_logical +! routine mpas_deallocate_field0D_logical ! -!> \brief MPAS 0D logical deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 0D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 0D logical field. +!> This routine deallocates a 0-d logical field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field0d_logical(f)!{{{ + + implicit none + type (field0dLogical), pointer :: f !< Input: Field to deallocate - type (field0dLogical), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() - - if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field0dLogical), pointer :: f_cursor, f_next - deallocate(f_cursor) - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_logical!}}} @@ -1432,43 +1444,39 @@ end subroutine mpas_deallocate_field0d_logical!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_integer +! routine mpas_deallocate_field0D_integer ! -!> \brief MPAS 0D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 0D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 0D integer field. +!> This routine deallocates a 0-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field0d_integer(f)!{{{ + + implicit none + type (field0dInteger), pointer :: f !< Input: Field to deallocate - type (field0dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() - - if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field0dInteger), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_integer!}}} @@ -1478,45 +1486,37 @@ end subroutine mpas_deallocate_field0d_integer!}}} ! ! routine mpas_deallocate_field1D_integer ! -!> \brief MPAS 1D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 1D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 1D integer field. +!> This routine deallocates a 1-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field1d_integer(f)!{{{ + + implicit none + type (field1dInteger), pointer :: f !< Input: Field to deallocate - type (field1dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + type (field1dInteger), pointer :: f_cursor, f_next - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_integer!}}} @@ -1526,45 +1526,37 @@ end subroutine mpas_deallocate_field1d_integer!}}} ! ! routine mpas_deallocate_field2D_integer ! -!> \brief MPAS 2D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 2D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 2D integer field. +!> This routine deallocates a 2-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field2d_integer(f)!{{{ + + implicit none + type (field2dInteger), pointer :: f !< Input: Field to deallocate - type (field2dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + type (field2dInteger), pointer :: f_cursor, f_next - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field2d_integer!}}} @@ -1574,45 +1566,37 @@ end subroutine mpas_deallocate_field2d_integer!}}} ! ! routine mpas_deallocate_field3D_integer ! -!> \brief MPAS 3D integer deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \brief MPAS 3D int deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 3D integer field. +!> This routine deallocates a 3-d integer field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field3d_integer(f)!{{{ + + implicit none + type (field3dInteger), pointer :: f !< Input: Field to deallocate - type (field3dInteger), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + type (field3dInteger), pointer :: f_cursor, f_next - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + call mpas_deallocate_field_target(f) - deallocate(f_cursor) - - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field3d_integer!}}} @@ -1620,44 +1604,39 @@ end subroutine mpas_deallocate_field3d_integer!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0d_real +! routine mpas_deallocate_field0D_real ! !> \brief MPAS 0D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 0D real field. +!> This routine deallocates a 0-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field0d_real(f)!{{{ - type (field0dReal), pointer :: f !< Input: Field to deallocate - type (field0dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - f_cursor => f + type (field0dReal), pointer :: f !< Input: Field to deallocate - if ( threadNum == 0 ) then - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field0dReal), pointer :: f_cursor, f_next - deallocate(f_cursor) - - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field0d_real!}}} @@ -1668,44 +1647,36 @@ end subroutine mpas_deallocate_field0d_real!}}} ! routine mpas_deallocate_field1D_real ! !> \brief MPAS 1D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 1D real field. +!> This routine deallocates a 1-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field1d_real(f)!{{{ - type (field1dReal), pointer :: f !< Input: Field to deallocate - type (field1dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field1dReal), pointer :: f !< Input: Field to deallocate + + type (field1dReal), pointer :: f_cursor, f_next - deallocate(f_cursor) + call mpas_deallocate_field_target(f) - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field1d_real!}}} @@ -1716,44 +1687,36 @@ end subroutine mpas_deallocate_field1d_real!}}} ! routine mpas_deallocate_field2D_real ! !> \brief MPAS 2D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 2D real field. +!> This routine deallocates a 2-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field2d_real(f)!{{{ - type (field2dReal), pointer :: f !< Input: Field to deallocate - type (field2dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field2dReal), pointer :: f !< Input: Field to deallocate - deallocate(f_cursor) + type (field2dReal), pointer :: f_cursor, f_next - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field2d_real!}}} @@ -1764,44 +1727,36 @@ end subroutine mpas_deallocate_field2d_real!}}} ! routine mpas_deallocate_field3D_real ! !> \brief MPAS 3D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 3D real field. +!> This routine deallocates a 3-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field3d_real(f)!{{{ - type (field3dReal), pointer :: f !< Input: Field to deallocate - type (field3dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field3dReal), pointer :: f !< Input: Field to deallocate + + type (field3dReal), pointer :: f_cursor, f_next - deallocate(f_cursor) + call mpas_deallocate_field_target(f) - f_cursor => f - end do + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field3d_real!}}} @@ -1812,44 +1767,36 @@ end subroutine mpas_deallocate_field3d_real!}}} ! routine mpas_deallocate_field4D_real ! !> \brief MPAS 4D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 4D real field. +!> This routine deallocates a 4-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field4d_real(f)!{{{ - type (field4dReal), pointer :: f !< Input: Field to deallocate - type (field4dReal), pointer :: f_cursor - integer :: threadNum - integer :: i, iErr - threadNum = mpas_threading_get_thread_num() + implicit none - if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + type (field4dReal), pointer :: f !< Input: Field to deallocate - deallocate(f_cursor) + type (field4dReal), pointer :: f_cursor, f_next - f_cursor => f - end do + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do end if end subroutine mpas_deallocate_field4d_real!}}} @@ -1860,139 +1807,753 @@ end subroutine mpas_deallocate_field4d_real!}}} ! routine mpas_deallocate_field5D_real ! !> \brief MPAS 5D real deallocation routine. -!> \author Doug Jacobsen -!> \date 04/02/13 +!> \author Michael G. Duda +!> \date 4 November 2019 !> \details -!> This routine deallocates a 5D real field. +!> This routine deallocates a 5-d real field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. ! !----------------------------------------------------------------------- subroutine mpas_deallocate_field5d_real(f)!{{{ + + implicit none + type (field5dReal), pointer :: f !< Input: Field to deallocate - type (field5dReal), pointer :: f_cursor + + type (field5dReal), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field5d_real!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_char +! +!> \brief MPAS 0D real deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 0-d character field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_char(f)!{{{ + + implicit none + + type (field0dChar), pointer :: f !< Input: Field to deallocate + + type (field0dChar), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field0d_char!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_char +! +!> \brief MPAS 1D char deallocation routine. +!> \author Michael G. Duda +!> \date 4 November 2019 +!> \details +!> This routine deallocates a 1-d character field. Upon return, all memory +!> that is uniquely associated with the field pointed to by f +!> (i.e., array storage, attribute lists, constitutent names; *not* sendList, +!> recvList, block, etc. that are potentially referenced by other fields) +!> will have been freed, and the input pointer will be nullified. +!> +!> For fields that are elements of an array of fields, do not use this +!> routine, and instead use mpas_deallocate_field_target. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_char(f)!{{{ + + implicit none + + type (field1dChar), pointer :: f !< Input: Field to deallocate + + type (field1dChar), pointer :: f_cursor, f_next + + call mpas_deallocate_field_target(f) + + if ( mpas_threading_get_thread_num() == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + deallocate(f_cursor) + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field1d_char!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_logical_target +! +!> \brief MPAS 0D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D logical field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_logical_target(f)!{{{ + + implicit none + + type (field0dLogical), target :: f !< Input: Field to deallocate + + type (field0dLogical), pointer :: f_cursor, f_next integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if - deallocate(f_cursor) + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if - end subroutine mpas_deallocate_field5d_real!}}} + end subroutine mpas_deallocate_field0d_logical_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field0D_char +! routine mpas_deallocate_field0D_integer_target ! -!> \brief MPAS 0D character deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 0D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 0D character field. +!> This routine deallocates a 0D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field0d_char(f)!{{{ - type (field0dChar), pointer :: f !< Input: Field to deallocate - type (field0dChar), pointer :: f_cursor + subroutine mpas_deallocate_field0d_integer_target(f)!{{{ + + implicit none + + type (field0dInteger), target :: f !< Input: Field to deallocate + + type (field0dInteger), pointer :: f_cursor, f_next integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then - f_cursor => f - - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - deallocate(f_cursor) - f_cursor => f - end do + f_cursor => f_next + end do end if - end subroutine mpas_deallocate_field0d_char!}}} + end subroutine mpas_deallocate_field0d_integer_target!}}} !*********************************************************************** ! -! routine mpas_deallocate_field1D_char +! routine mpas_deallocate_field1D_integer_target ! -!> \brief MPAS 1D character deallocation routine. -!> \author Doug Jacobsen +!> \brief MPAS 1D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda !> \date 04/02/13 !> \details -!> This routine deallocates a 1D character field. +!> This routine deallocates a 1D int field. ! !----------------------------------------------------------------------- - subroutine mpas_deallocate_field1d_char(f)!{{{ - type (field1dChar), pointer :: f !< Input: Field to deallocate - type (field1dChar), pointer :: f_cursor + subroutine mpas_deallocate_field1d_integer_target(f)!{{{ + + implicit none + + type (field1dInteger), target :: f !< Input: Field to deallocate + + type (field1dInteger), pointer :: f_cursor, f_next integer :: threadNum integer :: i, iErr threadNum = mpas_threading_get_thread_num() if ( threadNum == 0 ) then - f_cursor => f - do while(associated(f_cursor)) - if(associated(f % next)) then - f => f % next - else - nullify(f) - end if - - if(associated(f_cursor % array)) then - deallocate(f_cursor % array) - end if - - if ( associated(f_cursor % attLists) ) then - do i = 1, size(f_cursor % attLists, dim=1) - call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) - end do - deallocate(f_cursor % attLists) - end if + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if - deallocate(f_cursor) + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if - f_cursor => f - end do + f_cursor => f_next + end do end if - end subroutine mpas_deallocate_field1d_char!}}} + end subroutine mpas_deallocate_field1d_integer_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field2D_integer_target +! +!> \brief MPAS 2D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 2D int field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field2d_integer_target(f)!{{{ + + implicit none + + type (field2dInteger), target :: f !< Input: Field to deallocate + + type (field2dInteger), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field2d_integer_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field3D_integer_target +! +!> \brief MPAS 3D int deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 3D int field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field3d_integer_target(f)!{{{ + + implicit none + + type (field3dInteger), target :: f !< Input: Field to deallocate + + type (field3dInteger), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field3d_integer_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_real_target +! +!> \brief MPAS 0D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_real_target(f)!{{{ + + implicit none + + type (field0dReal), target :: f !< Input: Field to deallocate + + type (field0dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field0d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_real_target +! +!> \brief MPAS 1D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 1D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_real_target(f)!{{{ + + implicit none + + type (field1dReal), target :: f !< Input: Field to deallocate + + type (field1dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field1d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field2D_real_target +! +!> \brief MPAS 2D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 2D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field2d_real_target(f)!{{{ + + implicit none + + type (field2dReal), target :: f !< Input: Field to deallocate + + type (field2dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field2d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field3D_real_target +! +!> \brief MPAS 3D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 3D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field3d_real_target(f)!{{{ + + implicit none + + type (field3dReal), target :: f !< Input: Field to deallocate + + type (field3dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field3d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field4D_real_target +! +!> \brief MPAS 4D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 4D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field4d_real_target(f)!{{{ + + implicit none + + type (field4dReal), target :: f !< Input: Field to deallocate + + type (field4dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field4d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field5D_real_target +! +!> \brief MPAS 5D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 5D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field5d_real_target(f)!{{{ + + implicit none + + type (field5dReal), target :: f !< Input: Field to deallocate + + type (field5dReal), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field5d_real_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field0D_char_target +! +!> \brief MPAS 0D real deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 0D real field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field0d_char_target(f)!{{{ + + implicit none + + type (field0dChar), target :: f !< Input: Field to deallocate + + type (field0dChar), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field0d_char_target!}}} + + +!*********************************************************************** +! +! routine mpas_deallocate_field1D_char_target +! +!> \brief MPAS 1D char deallocation routine. +!> \author Doug Jacobsen, Michael G. Duda +!> \date 04/02/13 +!> \details +!> This routine deallocates a 1D char field. +! +!----------------------------------------------------------------------- + subroutine mpas_deallocate_field1d_char_target(f)!{{{ + + implicit none + + type (field1dChar), target :: f !< Input: Field to deallocate + + type (field1dChar), pointer :: f_cursor, f_next + integer :: threadNum + integer :: i, iErr + + threadNum = mpas_threading_get_thread_num() + + if ( threadNum == 0 ) then + f_cursor => f + do while(associated(f_cursor)) + f_next => f_cursor % next + + if (associated(f_cursor % array)) then + deallocate(f_cursor % array) + end if + + if (associated(f_cursor % attLists)) then + do i = 1, size(f_cursor % attLists, dim=1) + call mpas_deallocate_attlist(f_cursor % attLists(i) % attList, iErr) + end do + deallocate(f_cursor % attLists) + end if + + if (associated(f_cursor % constituentNames)) then + deallocate(f_cursor % constituentNames) + end if + + f_cursor => f_next + end do + end if + + end subroutine mpas_deallocate_field1d_char_target!}}} !*********************************************************************** diff --git a/src/framework/mpas_framework.F b/src/framework/mpas_framework.F index 974e0935ca..7986383656 100644 --- a/src/framework/mpas_framework.F +++ b/src/framework/mpas_framework.F @@ -27,6 +27,8 @@ module mpas_framework use mpas_io_units use mpas_block_decomp + private :: report_acc_devices + contains @@ -42,15 +44,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!}}} @@ -67,11 +77,18 @@ end subroutine mpas_framework_init_phase1!}}} !----------------------------------------------------------------------- subroutine mpas_framework_init_phase2(domain, io_system, calendar)!{{{ + use mpas_log, only : mpas_log_write + use mpas_derived_types, only : MPAS_LOG_CRIT + implicit none type (domain_type), pointer :: domain +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), optional, pointer :: io_system +#else + integer, optional, pointer :: io_system +#endif character(len=*), intent(in), optional :: calendar character(len=StrKIND), pointer :: config_calendar_type @@ -85,22 +102,51 @@ subroutine mpas_framework_init_phase2(domain, io_system, calendar)!{{{ call mpas_pool_set_error_level(MPAS_POOL_WARN) #endif - call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) - call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) - call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) - if (present(calendar)) then call mpas_timekeeping_init(calendar) else + call mpas_pool_get_config(domain % configs, 'config_calendar_type', config_calendar_type) call mpas_timekeeping_init(config_calendar_type) end if - pio_num_iotasks = config_pio_num_iotasks - pio_stride = config_pio_stride - if (pio_num_iotasks == 0) then - pio_num_iotasks = domain % dminfo % nprocs + ! + ! Note: pio_num_iotasks and pio_stride are only used in MPAS_io_init if io_system is + ! not present. In stand-alone configurations, we expect that io_system will not + ! be present and that pio_num_iotasks and pio_stride will be available from + ! the namelist; in other systems, a PIO io_system may be provided. + ! + if (.not. present(io_system)) then + call mpas_pool_get_config(domain % configs, 'config_pio_num_iotasks', config_pio_num_iotasks) + call mpas_pool_get_config(domain % configs, 'config_pio_stride', config_pio_stride) + pio_num_iotasks = config_pio_num_iotasks + pio_stride = config_pio_stride + + ! + ! If at most one of config_pio_num_iotasks and config_io_stride are zero, compute + ! a sensible value for the zero-valued option + ! + if (pio_num_iotasks == 0 .and. pio_stride == 0) then + call mpas_log_write('Namelist options config_pio_num_iotasks and config_pio_stride cannot both be zero.', & + messageType=MPAS_LOG_CRIT) + else if (pio_num_iotasks == 0) then + pio_num_iotasks = domain % dminfo % nprocs / pio_stride + else if (pio_stride == 0) then + pio_stride = domain % dminfo % nprocs / pio_num_iotasks + end if + + call mpas_log_write('') + call mpas_log_write('----- I/O task configuration: -----') + call mpas_log_write('') + call mpas_log_write(' I/O task count = $i', intArgs=[pio_num_iotasks]) + call mpas_log_write(' I/O task stride = $i', intArgs=[pio_stride]) + call mpas_log_write('') + else + pio_num_iotasks = -1 ! Not used when external io_system is provided + pio_stride = -1 ! Not used when external io_system is provided end if + domain % ioContext % dminfo => domain % dminfo + call MPAS_io_init(domain % ioContext, pio_num_iotasks, pio_stride, io_system) end subroutine mpas_framework_init_phase2!}}} @@ -122,7 +168,11 @@ subroutine mpas_framework_finalize(dminfo, domain, io_system)!{{{ type (dm_info), pointer :: dminfo type (domain_type), pointer :: domain +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), optional, pointer :: io_system +#else + integer, optional, pointer :: io_system +#endif call MPAS_io_finalize(domain % ioContext, .false.) @@ -136,4 +186,135 @@ subroutine mpas_framework_finalize(dminfo, domain, io_system)!{{{ end subroutine mpas_framework_finalize!}}} + +!----------------------------------------------------------------------- +! routine mpas_framework_report_settings +! +!> \brief Report information about compile- and run-time settings to the log file +!> \author Michael Duda +!> \date 1 May 2024 +!> \details +!> This routine writes information about compile-time and run-time settings for +!> an MPAS core to the log file. +! +!----------------------------------------------------------------------- + subroutine mpas_framework_report_settings(domain) + +#ifdef MPAS_OPENMP + use mpas_threading, only : mpas_threading_get_num_threads +#endif + + implicit none + + type (domain_type), pointer :: domain + + + call mpas_log_write('') + call mpas_log_write('Output from ''git describe --dirty'': '//trim(domain % core % git_version)) + + call mpas_log_write('') + call mpas_log_write('Compile-time options:') + call mpas_log_write(' Build target: '//trim(domain % core % build_target)) + call mpas_log_write(' OpenMP support: ' // & +#ifdef MPAS_OPENMP + 'yes') +#else + 'no') +#endif + call mpas_log_write(' OpenACC support: ' // & +#ifdef MPAS_OPENACC + 'yes') +#else + 'no') +#endif + call mpas_log_write(' Default real precision: ' // & +#ifdef SINGLE_PRECISION + 'single') +#else + 'double') +#endif + call mpas_log_write(' Compiler flags: ' // & +#ifdef MPAS_DEBUG + 'debug') +#else + 'optimize') +#endif + call mpas_log_write(' I/O layer: ' // & +#ifdef MPAS_PIO_SUPPORT +#ifdef USE_PIO2 + 'PIO 2.x') +#else + 'PIO 1.x') +#endif +#else + 'SMIOL') +#endif + call mpas_log_write('') + + call mpas_log_write('Run-time settings:') + call mpas_log_write(' MPI task count: $i', intArgs=[domain % dminfo % nprocs]) +#ifdef MPAS_OPENMP + call mpas_log_write(' OpenMP max threads: $i', intArgs=[mpas_threading_get_max_threads()]) +#endif + call mpas_log_write('') + +#ifdef MPAS_OPENACC + call report_acc_devices() +#endif + + end subroutine mpas_framework_report_settings + + +#ifdef MPAS_OPENACC + !*********************************************************************** + ! + ! function report_acc_devices + ! + !> \brief Queries OpenACC devices and reports device info to log file + !> \author Michael G. Duda + !> \date 28 March 2024 + !> \details + !> This routine makes use of the OpenACC runtime library to obtain + !> information about how many and which kind of OpenACC devices are + !> available to the current MPI rank. + !> + !> NB: This routine is only compiled and only called if OPENACC=true. + ! + !----------------------------------------------------------------------- + subroutine report_acc_devices() + + use mpas_c_interfacing, only : mpas_sanitize_string + use openacc, only : acc_get_property_string, acc_get_property, acc_get_num_devices, acc_get_device_num, & + acc_get_device_type, acc_device_kind, acc_device_property, acc_property_vendor, & + acc_property_name, acc_property_driver + + implicit none + + integer(kind=acc_device_kind) :: device + character(len=StrKIND) :: device_vendor, device_name, driver_vers + integer :: ndevices, device_num + + + device = acc_get_device_type() + ndevices = acc_get_num_devices(device) + device_num = acc_get_device_num(device_num) + call acc_get_property_string(device_num, device, acc_property_vendor, device_vendor) + call acc_get_property_string(device_num, device, acc_property_name, device_name) + call acc_get_property_string(device_num, device, acc_property_driver, driver_vers) + + call mpas_sanitize_string(device_vendor) + call mpas_sanitize_string(device_name) + call mpas_sanitize_string(driver_vers) + + call mpas_log_write('OpenACC configuration:') + call mpas_log_write(' Number of visible devices: $i', intArgs=[ndevices]) + call mpas_log_write(' Device # for this MPI task: $i', intArgs=[device_num]) + call mpas_log_write(' Device vendor: '//trim(device_vendor)) + call mpas_log_write(' Device name: '//trim(device_name)) + call mpas_log_write(' Device driver version: '//trim(driver_vers)) + call mpas_log_write('') + + end subroutine report_acc_devices +#endif + end module mpas_framework diff --git a/src/framework/mpas_halo.F b/src/framework/mpas_halo.F new file mode 100644 index 0000000000..09db77c5b2 --- /dev/null +++ b/src/framework/mpas_halo.F @@ -0,0 +1,1675 @@ +#define CONTIGUOUS contiguous, + +! Copyright (c) 2021-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_halo +! +!> \brief Communication of halos for groups of fields +!> \author Michael Duda +!> \date 29 September 2021 +!> \details +!> This module provides routines for defining groups of fields, and for +!> communicating the halos of all fields in a group. +! +!----------------------------------------------------------------------- +module mpas_halo + + implicit none + + private + + public :: mpas_halo_init, & + mpas_halo_finalize, & + mpas_halo_exch_group_create, & + mpas_halo_exch_group_complete, & + mpas_halo_exch_group_destroy, & + mpas_halo_exch_group_add_field, & + mpas_halo_exch_group_full_halo_exch + + + contains + + + !----------------------------------------------------------------------- + ! routine mpas_halo_init + ! + !> \brief Initialize halo exchange module + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine initialize the halo exchange module and must be + !> called before any other routine for building or exchanging halos. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_init(domain, iErr) + + use mpas_derived_types, only : domain_type + use mpas_pool_routines, only : mpas_pool_create_pool + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, optional, intent(out) :: iErr + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_create_pool(domain % haloGroupPool) + + end subroutine mpas_halo_init + + + !----------------------------------------------------------------------- + ! routine mpas_halo_finalize + ! + !> \brief Finalize halo exchange module + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine finalize the halo exchange module and must be + !> called after all other calls for building or exchanging halos. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_finalize(domain, iErr) + + use mpas_derived_types, only : domain_type + use mpas_pool_routines, only : mpas_pool_destroy_pool + + ! Arguments + type (domain_type), intent(inout) :: domain + integer, optional, intent(out) :: iErr + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_destroy_pool(domain % haloGroupPool) + + end subroutine mpas_halo_finalize + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_create + ! + !> \brief Create a new group, to which fields can be later added + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine creates a new group, into which fields can be added by + !> subsequent calls to mpas_halo_exch_group_add_field. After one or more + !> fields have been added to a group created by this routine, a call to + !> mpas_halo_exch_group_complete must be made before the halos of fields + !> in the group can be exchanged with a call to + !> mpas_halo_exch_group_full_halo_exch. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_create(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_pool_type + use mpas_pool_routines, only : mpas_pool_create_pool, mpas_pool_add_subpool + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + type (mpas_pool_type), pointer :: newGroup + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_create_pool(newGroup) + call mpas_pool_add_subpool(domain % haloGroupPool, groupName, newGroup) + + end subroutine mpas_halo_exch_group_create + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_complete + ! + !> \brief Complete the creation of an exchange group + !> \author Michael Duda + !> \date 29 September 2021 + !> \details + !> Complete the creation of an exchange group that was defined via a call + !> to the mpas_halo_exch_group_create routine, and to which fields were + !> added through calls to mpas_halo_exch_group_add_field. This routine + !> must be called for an exchange group before the group can be used in + !> calls to the mpas_halo_exch_group_full_halo_exch routine. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_complete(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_pool_type, mpas_pool_iterator_type, MPAS_POOL_CONFIG, & + MPAS_POOL_REAL, MPAS_HALO_REAL, mpas_halo_group, MPAS_LOG_CRIT, & + field2DReal, field3DReal + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_remove_subpool, mpas_pool_destroy_pool, & + mpas_pool_begin_iteration, mpas_pool_get_next_member, mpas_pool_get_dimension, & + mpas_pool_remove_field, mpas_pool_get_field + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i + type (mpas_pool_type), pointer :: completedGroup + type (mpas_pool_iterator_type) :: itr + integer, dimension(:), pointer :: fieldHaloInfo + integer, dimension(:), pointer :: haloLayers + type (mpas_halo_group), pointer :: newGroup + type (field2DReal), pointer :: r2d + type (field3DReal), pointer :: r3d + integer, pointer :: timeLevel + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_get_subpool(domain % haloGroupPool, groupName, completedGroup) + + ! + ! Add new mpas_halo_group to list of haloGroups in domain + ! + allocate(newGroup) + newGroup % groupName = groupName + newGroup % next => domain % haloGroups + domain % haloGroups => newGroup + + ! + ! Figure out how many fields are in this group + ! + newGroup % nFields = 0 + call mpas_pool_begin_iteration(completedGroup) + do while (mpas_pool_get_next_member(completedGroup, itr)) + if (itr % memberType == MPAS_POOL_CONFIG) then + newGroup % nFields = newGroup % nFields + 1 + end if + end do + + allocate(newGroup % fields(newGroup % nFields)) + + ! + ! Fill in field entries for this group + ! + i = 1 + call mpas_pool_begin_iteration(completedGroup) + do while (mpas_pool_get_next_member(completedGroup, itr)) + if (itr % memberType == MPAS_POOL_CONFIG) then + newGroup % fields(i) % fieldName = trim(itr % memberName) + + call mpas_pool_get_dimension(completedGroup, trim(itr % memberName)//'.info', fieldHaloInfo) + + call mpas_pool_get_dimension(completedGroup, trim(itr % memberName)//'.timelevel', timeLevel) + + call mpas_pool_get_dimension(completedGroup, trim(itr % memberName)//'.layers', haloLayers) + + newGroup % fields(i) % nDims = fieldHaloInfo(2) + newGroup % fields(i) % timeLevel = timeLevel + + select case (fieldHaloInfo(1)) + case (MPAS_POOL_REAL) + newGroup % fields(i) % fieldType = MPAS_HALO_REAL + case default + call mpas_log_write('Only real-valued fields are supported in mpas_halo_exch_group_complete', & + messageType=MPAS_LOG_CRIT) + end select + + if (fieldHaloInfo(1) == MPAS_POOL_REAL) then + if (fieldHaloInfo(2) == 2) then + call mpas_pool_get_field(completedGroup, trim(itr % memberName)//'.field', r2d) + call mpas_halo_compact_halo_info(domain, r2d % sendList, r2d % recvList, r2d % dimSizes, & + haloLayers, & + newGroup % fields(i) % compactHaloInfo, & + newGroup % fields(i) % compactSendLists, & + newGroup % fields(i) % compactRecvLists) + else if (fieldHaloInfo(2) == 3) then + call mpas_pool_get_field(completedGroup, trim(itr % memberName)//'.field', r3d) + call mpas_halo_compact_halo_info(domain, r3d % sendList, r3d % recvList, r3d % dimSizes, & + haloLayers, & + newGroup % fields(i) % compactHaloInfo, & + newGroup % fields(i) % compactSendLists, & + newGroup % fields(i) % compactRecvLists) + else + call mpas_log_write('Unsupported dimensionality for real field in mpas_halo_exch_group_complete.', & + messageType=MPAS_LOG_CRIT) + end if + else + call mpas_log_write('Unsupported field type in mpas_halo_exch_group_complete.', & + messageType=MPAS_LOG_CRIT) + end if + + call mpas_pool_remove_field(completedGroup, trim(itr % memberName)//'.field') + i = i + 1 + end if + end do + + call mpas_halo_aggregate_group_info(newGroup) + + ! + ! Pre-allocate buffers and MPI request lists + ! + allocate(newGroup % sendBuf(newGroup % groupSendBufSize)) + allocate(newGroup % recvBuf(newGroup % groupRecvBufSize)) + allocate(newGroup % sendRequests(newGroup % nGroupSendNeighbors)) + allocate(newGroup % recvRequests(newGroup % nGroupRecvNeighbors)) + + call mpas_pool_destroy_pool(completedGroup) + call mpas_pool_remove_subpool(domain % haloGroupPool, groupName) + + call refactor_lists(domain, groupName, iErr) + + end subroutine mpas_halo_exch_group_complete + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_destroy + ! + !> \brief Destroys a halo exchange group + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine frees memory associated with the named group, which must + !> have been previously created with calls to mpas_halo_exch_group_create + !> and mpas_halo_exch_group_complete. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_destroy(domain, groupName, iErr) + + use mpas_derived_types, only : domain_type, mpas_halo_group, MPAS_LOG_CRIT + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i + type (mpas_halo_group), pointer :: cursor, prev + + + if (present(iErr)) then + iErr = 0 + end if + + ! + ! Find this halo exhange group in the list of groups + ! + nullify(prev) + cursor => domain % haloGroups + do while (associated(cursor)) + if (trim(cursor % groupName) == trim(groupName)) then + exit + end if + + prev => cursor + cursor => cursor % next + end do + + if (.not. associated(cursor)) then + call mpas_log_write('Halo exchange group '//trim(groupName)//' not found in destroy routine.', & + messageType=MPAS_LOG_CRIT) + end if + + ! + ! Unlink this exchange group + ! + if (.not. associated(prev)) then + domain % haloGroups => cursor % next + else + prev % next => cursor % next + end if + + ! + ! Deallocate this exchange group + ! + do i = 1, cursor % nFields + deallocate(cursor % fields(i) % compactHaloInfo) + deallocate(cursor % fields(i) % compactSendLists) + deallocate(cursor % fields(i) % compactRecvLists) + deallocate(cursor % fields(i) % nSendLists) + deallocate(cursor % fields(i) % sendListSrc) + deallocate(cursor % fields(i) % sendListDst) + deallocate(cursor % fields(i) % packOffsets) + deallocate(cursor % fields(i) % nRecvLists) + deallocate(cursor % fields(i) % recvListSrc) + deallocate(cursor % fields(i) % recvListDst) + deallocate(cursor % fields(i) % unpackOffsets) + end do + deallocate(cursor % fields) + deallocate(cursor % groupPackOffsets) + deallocate(cursor % groupSendNeighbors) + deallocate(cursor % groupSendOffsets) + deallocate(cursor % groupSendCounts) + deallocate(cursor % groupUnpackOffsets) + deallocate(cursor % groupRecvNeighbors) + deallocate(cursor % groupToFieldRecvIdx) + deallocate(cursor % groupRecvOffsets) + deallocate(cursor % groupRecvCounts) + deallocate(cursor % sendBuf) + deallocate(cursor % recvBuf) + deallocate(cursor % sendRequests) + deallocate(cursor % recvRequests) + deallocate(cursor) + + end subroutine mpas_halo_exch_group_destroy + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_add_field + ! + !> \brief Add a field to a halo exchange group + !> \author Michael Duda + !> \date 17 November 2021 + !> \details + !> This routine adds the field named fieldName to the exchange group named + !> groupName. The timeLevel argument provides control over which time level + !> will be exchanged for the field. If the timeLevel argument is omitted, + !> time level 1 of the field will be exchanged. The haloLayers argument + !> specifies which halo layers will be exchanged for the field; if haloLayers + !> is not specified, all halo layers will be exchanged. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_add_field(domain, groupName, fieldName, timeLevel, haloLayers, iErr) + + use mpas_derived_types, only : domain_type, mpas_pool_type, mpas_pool_field_info_type, MPAS_POOL_REAL, & + field2DReal, field3DReal, MPAS_LOG_CRIT + use mpas_pool_routines, only : mpas_pool_get_subpool, mpas_pool_add_config, mpas_pool_get_field_info, & + mpas_pool_add_dimension, mpas_pool_get_field, mpas_pool_add_field + use mpas_log, only : mpas_log_write + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + character (len=*), intent(in) :: fieldName + integer, optional, intent(in) :: timeLevel + integer, dimension(:), optional, intent(in) :: haloLayers + integer, optional, intent(out) :: iErr + + ! Local variables + type (mpas_pool_type), pointer :: group + type (mpas_pool_field_info_type) :: info + integer, allocatable, dimension(:) :: fieldHaloInfo + integer :: local_timeLevel + type (field2DReal), pointer :: r2d + type (field3DReal), pointer :: r3d + + + if (present(iErr)) then + iErr = 0 + end if + + call mpas_pool_get_subpool(domain % haloGroupPool, groupName, group) + + ! + ! Store an item in the pool to signal the field whose halo is to be exchanged + ! + call mpas_pool_add_config(group, fieldName, 1) + + call mpas_pool_get_field_info(domain % blocklist % allFields, fieldName, info) + + ! + ! Store an item in the pool with basic info about this field + ! + allocate(fieldHaloInfo(4)) + fieldHaloInfo(1) = info % fieldType + fieldHaloInfo(2) = info % nDims + fieldHaloInfo(3) = info % nTimeLevels + fieldHaloInfo(4) = info % nHaloLayers + call mpas_pool_add_dimension(group, fieldName//'.info', fieldHaloInfo) + deallocate(fieldHaloInfo) + + ! + ! Store an item in the pool with list of halo layers to exchange, or (/-1/) if all layers + ! + if (present(haloLayers)) then + call mpas_pool_add_dimension(group, fieldName//'.layers', haloLayers) + else + call mpas_pool_add_dimension(group, fieldName//'.layers', (/ -1 /)) + end if + + ! + ! Store an item in the pool indicating which time level to exchange + ! + if (present(timeLevel)) then + local_timeLevel = timeLevel + else + local_timeLevel = 1 + end if + call mpas_pool_add_dimension(group, fieldName//'.timelevel', local_timeLevel) + + ! + ! Store a reference to the field itself in the pool + ! + if (info % fieldType == MPAS_POOL_REAL) then + if (info % nDims == 2) then + call mpas_pool_get_field(domain % blocklist % allFields, fieldName, r2d, timeLevel=local_timeLevel) + call mpas_pool_add_field(group, fieldName//'.field', r2d) + else if (info % nDims == 3) then + call mpas_pool_get_field(domain % blocklist % allFields, fieldName, r3d, timeLevel=local_timeLevel) + call mpas_pool_add_field(group, fieldName//'.field', r3d) + else + call mpas_log_write('Unsupported dimensionality for real field '//trim(fieldName), messageType=MPAS_LOG_CRIT) + end if + else + call mpas_log_write('Unsupported field type for field '//trim(fieldName), messageType=MPAS_LOG_CRIT) + end if + + end subroutine mpas_halo_exch_group_add_field + + + !----------------------------------------------------------------------- + ! routine mpas_halo_exch_group_full_halo_exch + ! + !> \brief Communicate halos for all fields in a group + !> \author Michael Duda + !> \date 15 August 2022 + !> \details + !> This routine exchanges the halos for all fields in the named halo + !> exchange group. + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_exch_group_full_halo_exch(domain, groupName, iErr) + +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_Datatype, MPI_Comm + use mpi_f08, only : MPI_REAL, MPI_DOUBLE_PRECISION, MPI_REQUEST_NULL, & + MPI_STATUS_IGNORE, MPI_STATUSES_IGNORE + use mpi_f08, only : MPI_Irecv, MPI_Isend, MPI_Waitany, MPI_Waitall +#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 + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i, bufstart, bufend + integer :: dim1, dim2 + integer :: i1, i2, j, iNeighbor, iReq + integer :: iHalo, iEndp + integer :: nHalos, nSendEndpts, nRecvEndpts + 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 + integer, dimension(:), pointer :: compactSendLists + integer, dimension(:), pointer :: compactRecvLists + integer, dimension(:,:), CONTIGUOUS pointer :: nSendLists + integer :: maxNSendList + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListSrc, sendListDst + integer, dimension(:), CONTIGUOUS pointer :: packOffsets + integer, dimension(:,:), CONTIGUOUS pointer :: nRecvLists + integer :: maxNRecvList + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListSrc, recvListDst + integer, dimension(:), CONTIGUOUS pointer :: unpackOffsets + + + if (present(iErr)) then + iErr = 0 + end if + + ! + ! Find this halo exhange group in the list of groups + ! + group => domain % haloGroups + do while (associated(group)) + if (trim(group % groupName) == trim(groupName)) then + exit + end if + + group => group % next + end do + + if (.not. associated(group)) then + call mpas_log_write('Halo exchange group '//trim(groupName)//' not found in full_exch routine.', & + messageType=MPAS_LOG_CRIT) + end if + + ! + ! Get the rank of this task and the MPI communicator to use from the first field in + ! 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) + + + ! + ! Initiate non-blocking MPI receives for all neighbors + ! + do i = 1, group % nGroupRecvNeighbors + if (group % groupRecvCounts(i) > 0) then + bufstart = group % groupRecvOffsets(i) + bufend = group % groupRecvOffsets(i) + group % groupRecvCounts(i) - 1 +!TO DO: how do we determine appropriate type here? + call MPI_Irecv(group % recvBuf(bufstart:bufend), group % groupRecvCounts(i), MPI_REALKIND, & + group % groupRecvNeighbors(i), group % groupRecvNeighbors(i), comm, & + group % recvRequests(i), mpi_ierr) + else + group % recvRequests(i) = MPI_REQUEST_NULL + end if + end do + + ! + ! Pack the segmented send buffer with elements from all fields and for all neighbors + ! + do i = 1, group % nFields + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactSendLists => group % fields(i) % compactSendLists + + ! + ! Packing code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + dim1 = compactHaloInfo(2) + dim2 = compactHaloInfo(3) + + nHalos = compactHaloInfo(9) + nSendEndpts = compactHaloInfo(10) + + sendListSrc => group % fields(i) % sendListSrc + sendListDst => group % fields(i) % sendListDst + nSendLists => group % fields(i) % nSendLists + packOffsets => group % fields(i) % packOffsets + maxNSendList = group % fields(i) % maxNSendList + + select case (group % fields(i) % nDims) + + ! + ! Packing code for 2-d real-valued fields + ! + case (2) + call mpas_pool_get_array(domain % blocklist % allFields, trim(group % fields(i) % fieldName), & + group % fields(i) % r2arr, timeLevel=group % fields(i) % timeLevel) + + ! + ! Pack send buffer for all neighbors for current field + ! + do iEndp = 1, nSendEndpts + do iHalo = 1, nHalos + do j = 1, maxNSendList + do i1 = 1, dim1 + if (j <= nSendLists(iHalo,iEndp)) then + group % sendBuf(packOffsets(iEndp) + dim1 * (sendListDst(j,iHalo,iEndp) - 1) + i1) = & + group % fields(i) % r2arr(i1, sendListSrc(j,iHalo,iEndp)) + end if + end do + end do + end do + end do + + ! + ! Packing code for 3-d real-valued fields + ! + case (3) + call mpas_pool_get_array(domain % blocklist % allFields, trim(group % fields(i) % fieldName), & + group % fields(i) % r3arr, group % fields(i) % timeLevel) + + ! + ! Pack send buffer for all neighbors for current field + ! + do iEndp = 1, nSendEndpts + do iHalo = 1, nHalos + do j = 1, maxNSendList + do i2 = 1, dim2 + do i1 = 1, dim1 + if (j <= nSendLists(iHalo,iEndp)) then + group % sendBuf(packOffsets(iEndp) + dim1*dim2*(sendListDst(j,iHalo,iEndp) - 1) & + + dim1*(i2-1) + i1) = & + group % fields(i) % r3arr(i1, i2, sendListSrc(j,iHalo,iEndp)) + end if + end do + end do + end do + end do + end do + + end select + end if + end do + + ! + ! Initiate non-blocking sends to all neighbors + ! + do i = 1, group % nGroupSendNeighbors + if (group % groupSendCounts(i) > 0) then + bufstart = group % groupSendOffsets(i) + bufend = group % groupSendOffsets(i) + group % groupSendCounts(i) - 1 +!TO DO: how do we determine appropriate type here? + call MPI_Isend(group % sendBuf(bufstart:bufend), group % groupSendCounts(i), MPI_REALKIND, & + group % groupSendNeighbors(i), rank, comm, & + group % sendRequests(i), mpi_ierr) + else + group % sendRequests(i) = MPI_REQUEST_NULL + end if + end do + + ! + ! Unpack messages as they are received + ! + do iNeighbor = 1, group % nGroupRecvNeighbors + + call MPI_Waitany(group % nGroupRecvNeighbors, group % recvRequests, iReq, MPI_STATUS_IGNORE, mpi_ierr) + + ! + ! Unpack the segmented recv buffer with elements for all fields and from all neighbors + ! + do i = 1, group % nFields + + ! Find field-local neighbor index corresponding to the neighbor for which we + ! just received a message. If iEndp == 0, then field i does not receive any + ! values from neighbor iReq + iEndp = group % groupToFieldRecvIdx(iReq, i) + + if (iEndp == 0) cycle ! No unpacking needed from this neighbor for this field + + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactRecvLists => group % fields(i) % compactRecvLists + + nHalos = compactHaloInfo(9) + nRecvEndpts = compactHaloInfo(11) + + recvListSrc => group % fields(i) % recvListSrc + recvListDst => group % fields(i) % recvListDst + nRecvLists => group % fields(i) % nRecvLists + unpackOffsets => group % fields(i) % unpackOffsets + maxNRecvList = group % fields(i) % maxNRecvList + + + ! + ! Unpacking code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + dim1 = compactHaloInfo(2) + dim2 = compactHaloInfo(3) + + select case (group % fields(i) % nDims) + + ! + ! Unpacking code for 2-d real-valued fields + ! + case (2) + ! + ! Unpack recv buffer from all neighbors for current field + ! + do iHalo = 1, nHalos + do j = 1, maxNRecvList + do i1 = 1, dim1 + if (j <= nRecvLists(iHalo,iEndp)) then + group % fields(i) % r2arr(i1, recvListDst(j,iHalo,iEndp)) = & + group % recvBuf(unpackOffsets(iEndp) + dim1 * (recvListSrc(j,iHalo,iEndp) - 1) + i1) + end if + end do + end do + end do + + ! + ! Unpacking code for 3-d real-valued fields + ! + case (3) + ! + ! Unpack recv buffer from all neighbors for current field + ! + do iHalo = 1, nHalos + do j = 1, maxNRecvList + do i2 = 1, dim2 + do i1 = 1, dim1 + if (j <= nRecvLists(iHalo,iEndp)) then + group % fields(i) % r3arr(i1, i2, recvListDst(j,iHalo,iEndp)) = & + group % recvBuf(unpackOffsets(iEndp) + dim1*dim2*(recvListSrc(j,iHalo,iEndp) - 1) & + + dim1*(i2-1) + i1) + end if + end do + end do + end do + end do + + end select + end if + end do + end do + + ! + ! Nullify array pointers - not necessary for correctness, but helpful when debugging + ! to not leave pointers to what might later be incorrect targets + ! + do i = 1, group % nFields + if (group % fields(i) % nDims == 2) then + nullify(group % fields(i) % r2arr) + else if (group % fields(i) % nDims == 3) then + nullify(group % fields(i) % r3arr) + end if + end do + + ! + ! Wait for all sends to complete before returning + ! + call MPI_Waitall(group % nGroupSendNeighbors, group % sendRequests, MPI_STATUSES_IGNORE, mpi_ierr) + + end subroutine mpas_halo_exch_group_full_halo_exch + + + !----------------------------------------------------------------------- + ! routine mpas_halo_compact_halo_info + ! + !> \brief Compacts information needed for halo exchanges + !> \author Michael Duda + !> \date 7 December 2017 + !> \details + !> This routine extracts all information needed to perform a halo exchange + !> from dynamic data types and places it into a single, contiguous array + !> for use by the mpas_halo_exch_halo_acc routines. + !> The resulting compactHaloInfo array has the following elements: + !> 1 - The dimensionality of the field + !> 2 - Dimension 1 of the field (i.e., the left-most dimension) + !> 3 - Dimension 2 of the field + !> 4 - Dimension 3 of the field + !> 5 - Dimension 4 of the field + !> 6 - Dimension 5 of the field + !> 7 - The MPI communicator + !> 8 - The MPI rank of the current process + !> 9 - The number of halo layers for the field + !> 10 - The number of endpoints to send to + !> 11 - The number of endpoints to recv from + !> + !> The compactSendLists and compactRecvLists arrays have the following elements: + !> foreach (send endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + !> foreach (recv endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_compact_halo_info(domain, sendList, recvList, dimSizes, haloLayers, & + compactHaloInfo, compactSendLists, compactRecvLists) + + use mpas_derived_types, only : domain_type, mpas_multihalo_exchange_list, mpas_exchange_list, MPAS_LOG_CRIT + use mpas_log, only : mpas_log_write + + implicit none + + ! Arguments + type (domain_type), intent(in) :: domain + type (mpas_multihalo_exchange_list), pointer :: sendList + type (mpas_multihalo_exchange_list), pointer :: recvList + integer, dimension(:), intent(in) :: dimsizes + integer, dimension(:), intent(in) :: haloLayers + integer, dimension(:), pointer :: compactHaloInfo + integer, dimension(:), pointer :: compactSendLists + integer, dimension(:), pointer :: compactRecvLists + + ! Local variables + integer :: i, iendpt, j, ioffset + integer :: idx + integer :: nSendEndpoints + integer :: maxSendEndpoints + integer :: totSendListSize + integer :: nRecvEndpoints + integer :: maxRecvEndpoints + integer :: totRecvListSize + integer :: nHaloLayers + logical :: found + integer, allocatable, dimension(:) :: sendEndpoints + integer, allocatable, dimension(:) :: recvEndpoints + type (mpas_multihalo_exchange_list), pointer :: sendListCursor, recvListCursor + type (mpas_exchange_list), pointer :: exchListPtr + integer :: activeHaloLayers + logical, dimension(:), allocatable :: useHalo + + + ! + ! Find number of halo layers + ! + nHaloLayers = size(sendList % halos) + if (nHaloLayers /= size(recvList % halos)) then + call mpas_log_write('The number of halo layers in the recv list does not match the number in the send list', & + messageType=MPAS_LOG_CRIT) + end if + + ! + ! Create logical array indicating, for each halo layer, whether that halo layer should be + ! used in a halo exchange + ! + allocate(useHalo(nHaloLayers)) + + if (haloLayers(1) == -1) then ! Use all halo layers + useHalo(:) = .true. + activeHaloLayers = nHaloLayers + else + useHalo(:) = .false. + activeHaloLayers = size(haloLayers) + do i = 1, activeHaloLayers + useHalo(haloLayers(i)) = .true. + end do + end if + + ! + ! Find the maximum number of "endpoints" that we will need to send to for any halo layer, + ! as well as the total size of the send lists for all halo layers + ! + maxSendEndpoints = 0 + totSendListSize = 0 + sendListCursor => sendList + do while (associated(sendListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + nSendEndpoints = 0 + exchListPtr => sendListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + nSendEndpoints = nSendEndpoints + 1 + totSendListSize = totSendListSize + 2 * exchListPtr % nList ! We have srcList and destList + exchListPtr => exchListPtr % next + end do + maxSendEndpoints = max(nSendEndpoints, maxSendEndpoints) + end if + end do + sendListCursor => sendListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + allocate(sendEndpoints(maxSendEndpoints * activeHaloLayers)) + + ! + ! Gather a list of the unique endpoints that we will need to send to + ! + nSendEndpoints = 0 + sendListCursor => sendList + do while (associated(sendListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + exchListPtr => sendListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + + ! If the current endpoint is not already in the list, add it + do j=1,nSendEndpoints + if (exchListPtr % endPointID == sendEndpoints(j)) exit + end do + if (j > nSendEndpoints) then + nSendEndpoints = nSendEndpoints + 1 + sendEndpoints(nSendEndpoints) = exchListPtr % endPointID + end if + + exchListPtr => exchListPtr % next + end do + end if + end do + sendListCursor => sendListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + ! + ! Find the maximum number of "endpoints" that we will need to receive from for any halo layer, + ! as well as the total size of the recv lists for all halo layers + ! + maxRecvEndpoints = 0 + totRecvListSize = 0 + recvListCursor => recvList + do while (associated(recvListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + nRecvEndpoints = 0 + exchListPtr => recvListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + nRecvEndpoints = nRecvEndpoints + 1 + totRecvListSize = totRecvListSize + 2 * exchListPtr % nList ! We have srcList and destList + exchListPtr => exchListPtr % next + end do + maxRecvEndpoints = max(nRecvEndpoints, maxRecvEndpoints) + end if + end do + recvListCursor => recvListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + allocate(recvEndpoints(maxRecvEndpoints * activeHaloLayers)) + + ! + ! Gather a list of the unique endpoints that we will need to receive from + ! + nRecvEndpoints = 0 + recvListCursor => recvList + do while (associated(recvListCursor)) + do i=1,nHaloLayers + if (useHalo(i)) then + exchListPtr => recvListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + + ! If the current endpoint is not already in the list, add it + do j=1,nRecvEndpoints + if (exchListPtr % endPointID == recvEndpoints(j)) exit + end do + if (j > nRecvEndpoints) then + nRecvEndpoints = nRecvEndpoints + 1 + recvEndpoints(nRecvEndpoints) = exchListPtr % endPointID + end if + + exchListPtr => exchListPtr % next + end do + end if + end do + recvListCursor => recvListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + + + ! + ! Compute the number of elements we will need in compactHaloInfo + ! + allocate(compactHaloInfo(11)) + allocate(compactSendLists(nSendEndpoints + activeHaloLayers * nSendEndpoints + totSendListSize)) + allocate(compactRecvLists(nRecvEndpoints + activeHaloLayers * nRecvEndpoints + totRecvListSize)) + + compactHaloInfo(:) = 0 + compactSendLists(:) = 0 + compactRecvLists(:) = 0 + + ! + ! 1-6: Add field dimensionality and dimensions + ! + compactHaloInfo(1) = size(dimSizes) ! Dimensionality of the field + idx = 2 + do i=1,compactHaloInfo(1) + compactHaloInfo(idx) = dimSizes(i) + idx = idx + 1 + end do + + ! + ! 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 + + ! + ! 9: Add number of halo layers + ! + compactHaloInfo(idx) = activeHaloLayers + idx = idx + 1 + + ! + ! 10: Add number of send endpoints + ! + compactHaloInfo(idx) = nSendEndpoints + idx = idx + 1 + + ! + ! 11: Add number of receive endpoints + ! + compactHaloInfo(idx) = nRecvEndpoints + idx = idx + 1 + + ! + ! foreach (endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + ! + idx = 1 + do iendpt=1,nSendEndpoints + compactSendLists(idx) = sendEndpoints(iendpt) + idx = idx + 1 + ioffset = 0 + do i=1,nHaloLayers + if (useHalo(i)) then + sendListCursor => sendList + do while (associated(sendListCursor)) + found = .false. + exchListPtr => sendListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + if (exchListPtr % endPointID == sendEndpoints(iendpt)) then + found = .true. + compactSendLists(idx) = exchListPtr % nList + idx = idx + 1 + compactSendLists(idx:idx+exchListPtr % nList-1) = exchListPtr % srcList(1:exchListPtr % nList) + idx = idx + exchListPtr % nList + compactSendLists(idx:idx+exchListPtr % nList-1) = exchListPtr % destList(1:exchListPtr % nList) + & + ioffset + idx = idx + exchListPtr % nList + ioffset = ioffset + exchListPtr % nList + exit + end if + exchListPtr => exchListPtr % next + end do + if (.not. found) then + compactSendLists(idx) = 0 + idx = idx + 1 + end if + sendListCursor => sendListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + end if + end do + end do + + deallocate(sendEndpoints) + + ! + ! foreach (endpoint) { endPointID foreach (halolayer) {nList srcList(1:nList) destList(1:nList)} } + ! + idx = 1 + do iendpt=1,nRecvEndpoints + compactRecvLists(idx) = recvEndpoints(iendpt) + idx = idx + 1 + ioffset = 0 + do i=1,nHaloLayers + if (useHalo(i)) then + recvListCursor => recvList + do while (associated(recvListCursor)) + found = .false. + exchListPtr => recvListCursor % halos(i) % exchList + do while (associated(exchListPtr)) + if (exchListPtr % endPointID == recvEndpoints(iendpt)) then + found = .true. + compactRecvLists(idx) = exchListPtr % nList + idx = idx + 1 + compactRecvLists(idx:idx+exchListPtr % nList-1) = exchListPtr % srcList(1:exchListPtr % nList) + & + ioffset + idx = idx + exchListPtr % nList + compactRecvLists(idx:idx+exchListPtr % nList-1) = exchListPtr % destList(1:exchListPtr % nList) + idx = idx + exchListPtr % nList + ioffset = ioffset + exchListPtr % nList + exit + end if + exchListPtr => exchListPtr % next + end do + if (.not. found) then + compactRecvLists(idx) = 0 + idx = idx + 1 + end if + recvListCursor => recvListCursor % next ! Expected to iterate just once for MPAS-Atmosphere + end do + end if + end do + end do + + deallocate(recvEndpoints) + + deallocate(useHalo) + + end subroutine mpas_halo_compact_halo_info + + + !----------------------------------------------------------------------- + ! routine mpas_halo_aggregate_group_info + ! + !> \brief Aggregate exchange info from all fields in a halo exchange group + !> \author Michael Duda + !> \date 23 November 2021 + !> \details + !> Given an mpas_halo_group, this routine aggregates information from across + !> all mpas_halo_field members of the group. + !> The end result of this routine is a set of arrays that can be used by + !> the mpas_halo_exch_group_full_halo_exch routine to pack/unpack buffers + !> and launch MPI sends and receives: + !> + !> nGroupSendNeighbors + !> groupSendBufSize + !> groupPackOffsets + !> groupSendNeighbors + !> groupSendOffsets + !> groupSendCounts + !> + !> nGroupRecvNeighbors + !> groupRecvBufSize + !> groupUnpackOffsets + !> groupRecvNeighbors + !> groupToFieldRecvEndpt + !> groupRecvOffsets + !> groupRecvCounts + ! + !----------------------------------------------------------------------- + subroutine mpas_halo_aggregate_group_info(group, ierr) + + use mpas_derived_types, only : mpas_halo_group + + ! Arguments + type (mpas_halo_group), intent(inout) :: group + integer, intent(out), optional :: ierr + + ! Local variables + integer :: i, j, idx, ihalo, iendp, nlist + integer :: ndims, ninnerelems + integer :: maxGroupSendNeighbors, maxGroupRecvNeighbors + integer, allocatable, dimension(:) :: sendNeighbors, recvNeighbors + integer, allocatable, dimension(:,:) :: sendCounts, recvCounts + + + if (present(ierr)) then + ierr = 0 + end if + + ! + ! Compute an upper bound on the number of send and recv neighbors for this group + ! + maxGroupSendNeighbors = 0 + maxGroupRecvNeighbors = 0 + do i = 1, group % nFields + maxGroupSendNeighbors = maxGroupSendNeighbors + group % fields(i) % compactHaloInfo(10) + maxGroupRecvNeighbors = maxGroupRecvNeighbors + group % fields(i) % compactHaloInfo(11) + end do + + + ! + ! Create a list of unique send and recv neighbors for this group + ! + allocate(sendNeighbors(maxGroupSendNeighbors)) + allocate(recvNeighbors(maxGroupRecvNeighbors)) + + sendNeighbors(:) = -1 + recvNeighbors(:) = -1 + + group % nGroupSendNeighbors = 0 + group % nGroupRecvNeighbors = 0 + + do i = 1, group % nFields + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(10) + + ! Try to locate this endPointID in the list + do j = 1, group % nGroupSendNeighbors + if (sendNeighbors(j) == group % fields(i) % compactSendLists(idx)) then + exit + end if + end do + + ! If endPointID was not found, add it to the list + if (j > group % nGroupSendNeighbors) then + group % nGroupSendNeighbors = group % nGroupSendNeighbors + 1 + sendNeighbors(group % nGroupSendNeighbors) = group % fields(i) % compactSendLists(idx) + end if + + ! Skip over remaining info for this endpoint + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactSendLists(idx) + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(11) + + ! Try to locate this endPointID in the list + do j = 1, group % nGroupRecvNeighbors + if (recvNeighbors(j) == group % fields(i) % compactRecvLists(idx)) then + exit + end if + end do + + ! If endPointID was not found, add it to the list + if (j > group % nGroupRecvNeighbors) then + group % nGroupRecvNeighbors = group % nGroupRecvNeighbors + 1 + recvNeighbors(group % nGroupRecvNeighbors) = group % fields(i) % compactRecvLists(idx) + end if + + ! Skip over remaining info for this endpoint + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactRecvLists(idx) + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + end do + + allocate(group % groupSendNeighbors(group % nGroupSendNeighbors)) + group % groupSendNeighbors(:) = sendNeighbors(1:group % nGroupSendNeighbors) + + allocate(group % groupRecvNeighbors(group % nGroupRecvNeighbors)) + group % groupRecvNeighbors(:) = recvNeighbors(1:group % nGroupRecvNeighbors) + + allocate(group % groupToFieldRecvIdx(group % nGroupRecvNeighbors, group % nFields)) + group % groupToFieldRecvIdx(:,:) = 0 + + deallocate(sendNeighbors) + deallocate(recvNeighbors) + + + ! + ! Compute total size of send and receive buffers for this group + ! + group % groupSendBufSize = 0 + group % groupRecvBufSize = 0 + + do i = 1, group % nFields + + ndims = group % fields(i) % compactHaloInfo(1) + ninnerelems = 1 + do j = 1, ndims - 1 ! Do not include right-most dimension (nCells, nEdges, or nVertices) + ninnerelems = ninnerelems * group % fields(i) % compactHaloInfo(j + 1) ! First dim is at (2), etc. + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(10) + + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactSendLists(idx) + group % groupSendBufSize = group % groupSendBufSize + ninnerelems * nlist + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(11) + + idx = idx + 1 ! skip over endPointID + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactRecvLists(idx) + group % groupRecvBufSize = group % groupRecvBufSize + ninnerelems * nlist + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + end do + + + ! + ! Compute sizes and offsets in group send and recv buffers for all fields in group + ! + allocate(group % groupPackOffsets(group % nGroupSendNeighbors, group % nFields)) + allocate(group % groupSendOffsets(group % nGroupSendNeighbors)) + allocate(group % groupSendCounts(group % nGroupSendNeighbors)) + group % groupPackOffsets(:,:) = -1 + group % groupSendOffsets(:) = -1 + group % groupSendCounts(:) = -1 + + allocate(group % groupUnpackOffsets(group % nGroupRecvNeighbors, group % nFields)) + allocate(group % groupRecvOffsets(group % nGroupRecvNeighbors)) + allocate(group % groupRecvCounts(group % nGroupRecvNeighbors)) + group % groupUnpackOffsets(:,:) = -1 + group % groupRecvOffsets(:) = -1 + group % groupRecvCounts(:) = -1 + + allocate(sendCounts(group % nGroupSendNeighbors, group % nFields)) + allocate(recvCounts(group % nGroupRecvNeighbors, group % nFields)) + sendCounts(:,:) = 0 + recvCounts(:,:) = 0 + + do i = 1, group % nFields + + ndims = group % fields(i) % compactHaloInfo(1) + ninnerelems = 1 + do j = 1, ndims - 1 ! Do not include right-most dimension (nCells, nEdges, or nVertices) + ninnerelems = ninnerelems * group % fields(i) % compactHaloInfo(j + 1) ! First dim is at (2), etc. + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(10) + + ! Find neighbor in groupSendNeighbors + do j = 1, group % nGroupSendNeighbors + if (group % fields(i) % compactSendLists(idx) == group % groupSendNeighbors(j)) then + exit + end if + end do + + idx = idx + 1 ! skip over endPointID + sendCounts(j, i) = 0 + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactSendLists(idx) + sendCounts(j, i) = sendCounts(j, i) + nlist * ninnerelems + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + idx = 1 + do iendp = 1, group % fields(i) % compactHaloInfo(11) + + ! Find neighbor in groupRecvNeighbors + do j = 1, group % nGroupRecvNeighbors + if (group % fields(i) % compactRecvLists(idx) == group % groupRecvNeighbors(j)) then + group % groupToFieldRecvIdx(j, i) = iendp + exit + end if + end do + + idx = idx + 1 ! skip over endPointID + recvCounts(j, i) = 0 + do ihalo = 1, group % fields(i) % compactHaloInfo(9) + nlist = group % fields(i) % compactRecvLists(idx) + recvCounts(j, i) = recvCounts(j, i) + nlist * ninnerelems + + idx = idx + 1 ! skip over nList + idx = idx + 2 * nlist ! skip over srcList and destList + end do + end do + + end do + + do j = 1, group % nGroupSendNeighbors + group % groupPackOffsets(j, 1) = 0 + do i = 2, group % nFields + group % groupPackOffsets(j, i) = group % groupPackOffsets(j, i-1) + sendCounts(j, i-1) + end do + end do + + do j = 1, group % nGroupRecvNeighbors + group % groupUnpackOffsets(j, 1) = 0 + do i = 2, group % nFields + group % groupUnpackOffsets(j, i) = group % groupUnpackOffsets(j, i-1) + recvCounts(j, i-1) + end do + end do + + do j = 1, group % nGroupSendNeighbors + group % groupSendCounts(j) = 0 + do i = 1, group % nFields + group % groupSendCounts(j) = group % groupSendCounts(j) + sendCounts(j, i) + end do + + if (j == 1) then + group % groupSendOffsets(j) = 1 + else + group % groupSendOffsets(j) = group % groupSendOffsets(j-1) + group % groupSendCounts(j-1) + + do i = 1, group % nFields + group % groupPackOffsets(j, i) = group % groupPackOffsets(j, i) + group % groupSendOffsets(j) - 1 + end do + end if + end do + + do j = 1, group % nGroupRecvNeighbors + group % groupRecvCounts(j) = 0 + do i = 1, group % nFields + group % groupRecvCounts(j) = group % groupRecvCounts(j) + recvCounts(j, i) + end do + + if (j == 1) then + group % groupRecvOffsets(j) = 1 + else + group % groupRecvOffsets(j) = group % groupRecvOffsets(j-1) + group % groupRecvCounts(j-1) + + do i = 1, group % nFields + group % groupUnpackOffsets(j, i) = group % groupUnpackOffsets(j, i) + group % groupRecvOffsets(j) - 1 + end do + end if + end do + + deallocate(sendCounts) + deallocate(recvCounts) + + end subroutine mpas_halo_aggregate_group_info + + + !----------------------------------------------------------------------- + ! routine refactor_lists + ! + !> \brief Convert compact{Send,Recv}Lists into multi-dimensional arrays + !> \author Michael Duda + !> \date 25 May 2022 + !> \details + !> For each field in the halo exchange group identified by groupName, + !> convert the compact{Send,Recv}Lists 1-d arrays into multi-dimensional + !> arrays that allow for more optimal pack and unpack loops in the + !> mpas_halo_exch_group_full_halo_exch routine. + !> + !> The following members in the mpas_halo_field type are allocated and + !> set by this routine: + !> + !> nSendLists + !> maxNSendList + !> sendListSrc + !> sendListDst + !> packOffsets + !> + !> nRecvLists + !> maxNRecvList + !> recvListSrc + !> recvListDst + !> unpackOffsets + ! + !----------------------------------------------------------------------- + subroutine refactor_lists(domain, groupName, iErr) + + 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 + + ! Arguments + type (domain_type), intent(inout) :: domain + character (len=*), intent(in) :: groupName + integer, optional, intent(out) :: iErr + + ! Local variables + integer :: i + integer :: iNeighbor, j + integer :: iHalo, iEndp + integer :: nHalos, nSendEndpts, nRecvEndpts + integer :: idx, idx_local + type (mpas_halo_group), pointer :: group + integer, dimension(:), pointer :: compactHaloInfo + integer, dimension(:), pointer :: compactSendLists + integer, dimension(:), pointer :: compactRecvLists + integer :: maxNSendList + integer, dimension(:,:), CONTIGUOUS pointer :: nSendLists + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListSrc, sendListDst + integer, dimension(:), CONTIGUOUS pointer :: packOffsets + integer :: maxNRecvList + integer, dimension(:,:), CONTIGUOUS pointer :: nRecvLists + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListSrc, recvListDst + integer, dimension(:), CONTIGUOUS pointer :: unpackOffsets + + + if (present(iErr)) then + iErr = 0 + end if + + ! + ! Find this halo exhange group in the list of groups + ! + group => domain % haloGroups + do while (associated(group)) + if (trim(group % groupName) == trim(groupName)) then + exit + end if + + group => group % next + end do + + if (.not. associated(group)) then + call mpas_log_write('Halo exchange group '//trim(groupName)//' not found in refactor_lists.', & + messageType=MPAS_LOG_CRIT) + end if + + + ! + ! Pack the segmented send buffer with elements from all fields and for all neighbors + ! + do i = 1, group % nFields + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactSendLists => group % fields(i) % compactSendLists + + ! + ! Packing code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + nHalos = compactHaloInfo(9) + nSendEndpts = compactHaloInfo(10) + idx = 1 + + allocate(group % fields(i) % nSendLists(3,nSendEndpts)) ! MGD fix hard-coded 3 later... + allocate(group % fields(i) % packOffsets(nSendEndpts)) + + nSendLists => group % fields(i) % nSendLists + packOffsets => group % fields(i) % packOffsets + + nSendLists(:,:) = 0 + packOffsets(:) = 0 + + idx_local = idx + + do iEndp = 1, nSendEndpts + ! Find this endpoint in the list of neighbors + do iNeighbor = 1, group % nGroupSendNeighbors + if (group % groupSendNeighbors(iNeighbor) == compactSendLists(idx)) exit + end do + idx = idx + 1 + + packOffsets(iEndp) = group % groupPackOffsets(iNeighbor, i) + + do iHalo = 1, nHalos + nSendLists(iHalo,iEndp) = compactSendLists(idx) + idx = idx + 1 + idx = idx + 2*nSendLists(iHalo,iEndp) + end do + end do + + maxNSendList = maxval(nSendLists) + group % fields(i) % maxNSendList = maxNSendList + + allocate(group % fields(i) % sendListSrc(maxNSendList,nHalos,nSendEndpts)) + allocate(group % fields(i) % sendListDst(maxNSendList,nHalos,nSendEndpts)) + + sendListSrc => group % fields(i) % sendListSrc + sendListDst => group % fields(i) % sendListDst + + sendListSrc(:,:,:) = 0 + sendListDst(:,:,:) = 0 + + idx = idx_local + + do iEndp = 1, nSendEndpts + idx = idx + 1 + + do iHalo = 1, nHalos + idx = idx + 1 + do j = 1, nSendLists(iHalo,iEndp) + sendListSrc(j,iHalo,iEndp) = compactSendLists(idx + j - 1) + sendListDst(j,iHalo,iEndp) = compactSendLists(idx + nSendLists(iHalo,iEndp) + j - 1) + end do + idx = idx + 2*nSendLists(iHalo,iEndp) + end do + end do + + end if + end do + + + ! + ! Unpack the segmented recv buffer with elements for all fields and from all neighbors + ! + do i = 1, group % nFields + + compactHaloInfo => group % fields(i) % compactHaloInfo + compactRecvLists => group % fields(i) % compactRecvLists + + idx = 1 + + ! + ! Unpacking code for real-valued fields + ! + if (group % fields(i) % fieldType == MPAS_HALO_REAL) then + nHalos = compactHaloInfo(9) + nRecvEndpts = compactHaloInfo(11) + idx = 1 + + allocate(group % fields(i) % nRecvLists(3,nRecvEndpts)) ! MGD fix hard-coded 3 later... + allocate(group % fields(i) % unpackOffsets(nRecvEndpts)) + + nRecvLists => group % fields(i) % nRecvLists + unpackOffsets => group % fields(i) % unpackOffsets + + nRecvLists(:,:) = 0 + unpackOffsets(:) = 0 + + idx_local = idx + + do iEndp = 1, nRecvEndpts + ! Find this endpoint in the list of neighbors + do iNeighbor = 1, group % nGroupRecvNeighbors + if (group % groupRecvNeighbors(iNeighbor) == compactRecvLists(idx)) exit + end do + idx = idx + 1 + + unpackOffsets(iEndp) = group % groupUnpackOffsets(iNeighbor, i) + + do iHalo = 1, nHalos + nRecvLists(iHalo,iEndp) = compactRecvLists(idx) + idx = idx + 1 + idx = idx + 2*nRecvLists(iHalo,iEndp) + end do + end do + + maxNRecvList = maxval(nRecvLists) + group % fields(i) % maxNRecvList = maxNRecvList + + allocate(group % fields(i) % recvListSrc(maxNRecvList,nHalos,nRecvEndpts)) + allocate(group % fields(i) % recvListDst(maxNRecvList,nHalos,nRecvEndpts)) + + recvListSrc => group % fields(i) % recvListSrc + recvListDst => group % fields(i) % recvListDst + + recvListSrc(:,:,:) = 0 + recvListDst(:,:,:) = 0 + + idx = idx_local + + do iEndp = 1, nRecvEndpts + idx = idx + 1 + + do iHalo = 1, nHalos + idx = idx + 1 + do j = 1, nRecvLists(iHalo,iEndp) + recvListSrc(j,iHalo,iEndp) = compactRecvLists(idx + j - 1) + recvListDst(j,iHalo,iEndp) = compactRecvLists(idx + nRecvLists(iHalo,iEndp) + j - 1) + end do + idx = idx + 2*nRecvLists(iHalo,iEndp) + end do + end do + + end if + end do + + end subroutine refactor_lists + +end module mpas_halo diff --git a/src/framework/mpas_halo_types.inc b/src/framework/mpas_halo_types.inc new file mode 100644 index 0000000000..5efafd0399 --- /dev/null +++ b/src/framework/mpas_halo_types.inc @@ -0,0 +1,85 @@ +#define CONTIGUOUS contiguous, + + integer, parameter :: MPAS_HALO_INVALID = -1 + + integer, parameter :: MPAS_HALO_REAL = 5001, & + MPAS_HALO_INTEGER = 5002 + + + ! + ! Information about an individual field in a halo group + ! + type mpas_halo_field + character(len=StrKIND) :: fieldName = '' ! Name of the field + integer :: nDims = MPAS_HALO_INVALID ! Number of dimensions for field + integer :: fieldType = MPAS_HALO_INVALID ! Field type: MPAS_HALO_REAL, MPAS_HALO_INTEGER + integer :: timeLevel = MPAS_HALO_INVALID ! Which time level to exchange + + integer, dimension(:), pointer :: compactHaloInfo => null() ! Information about halo communication for this field + integer, dimension(:), pointer :: compactSendLists => null() ! Elements sent to each neighbor + integer, dimension(:), pointer :: compactRecvLists => null() ! Elements received from each neighbor + + integer, dimension(:,:), CONTIGUOUS pointer :: nSendLists => null() ! (3,nSendEndpoints) 3 is assumed max halos + integer :: maxNSendList ! maxval(nSendLists) + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListSrc => null() ! (maxNSendList,nHalos,nSendEndpts) + integer, dimension(:,:,:), CONTIGUOUS pointer :: sendListDst => null() ! (maxNSendList,nHalos,nSendEndpts) + integer, dimension(:), CONTIGUOUS pointer :: packOffsets => null() ! (nSendEndpts) + + integer, dimension(:,:), CONTIGUOUS pointer :: nRecvLists => null() ! (3,nRecvEndpoints) 3 is assumed max halos + integer :: maxNRecvList ! maxval(nRecvLists) + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListSrc => null() ! (maxNRecvList,nHalos,nRecvEndpts) + integer, dimension(:,:,:), CONTIGUOUS pointer :: recvListDst => null() ! (maxNRecvList,nHalos,nRecvEndpts) + integer, dimension(:), CONTIGUOUS pointer :: unpackOffsets => null() ! (nRecvEndpts) + + real (kind=RKIND), dimension(:,:), pointer :: r2arr => null() ! Pointer to field array, only used internally + real (kind=RKIND), dimension(:,:,:), pointer :: r3arr => null() ! Pointer to field array, only used internally + end type mpas_halo_field + + + ! + ! Information about an entire halo group + ! + type mpas_halo_group + character(len=StrKIND) :: groupName = '' ! Name of the group + integer :: nFields = MPAS_HALO_INVALID ! Number of fields in the group + type (mpas_halo_field), dimension(:), pointer :: fields => null() ! Array of field halo info types, dimensioned nFields + + 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 +#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 + ! dimensioned (nGroupSendNeighbors) + integer, dimension(:), pointer :: groupSendOffsets => null() ! Offset in sendBuf of segment to send to each neighbor + ! dimensioned (nGroupSendNeighbors) + integer, dimension(:), pointer :: groupSendCounts => null() ! Size of sendBuf segment to send to each neighbor + ! dimensioned (nGroupSendNeighbors) + + 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 +#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 + ! dimensioned (nGroupRecvNeighbors) + integer, dimension(:,:), pointer :: groupToFieldRecvIdx => null() ! Convert from group-wide neighbor indices to + ! field-local indices + ! dimensioned (nGroupRecvNeighbors, nFields) + integer, dimension(:), pointer :: groupRecvOffsets => null() ! Offset in recvBuf of segment to recv from each neighbor + ! dimensioned (nGroupRecvNeighbors) + integer, dimension(:), pointer :: groupRecvCounts => null() ! Size of recvBuf segment to recv from each neighbor + ! dimensioned (nGroupRecvNeighbors) + + type (mpas_halo_group), pointer :: next => null() ! Pointer to the next halo group + end type mpas_halo_group diff --git a/src/framework/mpas_io.F b/src/framework/mpas_io.F index 2c17d3c661..a9ddee472c 100644 --- a/src/framework/mpas_io.F +++ b/src/framework/mpas_io.F @@ -12,6 +12,7 @@ module mpas_io use mpas_dmpar use mpas_log +#ifdef MPAS_PIO_SUPPORT use pio use piolib_mod use pionfatt_mod @@ -22,7 +23,19 @@ module mpas_io #else integer, parameter :: PIO_REALKIND = PIO_DOUBLE #endif +#endif + +#ifdef MPAS_SMIOL_SUPPORT + use SMIOLf + +#include "smiol_codes.inc" +#endif +#ifdef MPAS_PIO_SUPPORT + + ! + ! PIO-based fill values + ! #ifdef USE_PIO2 integer, parameter :: MPAS_INT_FILLVAL = PIO_FILL_INT character, parameter :: MPAS_CHAR_FILLVAL = achar(0) ! TODO: To be replaced with PIO_FILL_CHAR once PIO2 provides this variable @@ -45,6 +58,37 @@ module mpas_io #endif #endif +#else + +#ifdef MPAS_SMIOL_SUPPORT + + ! + ! SMIOL-based fill values + ! + integer, parameter :: MPAS_INT_FILLVAL = huge(0) + character, parameter :: MPAS_CHAR_FILLVAL = achar(0) + real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = huge(0.0_RKIND) + +#else + + ! + ! Default fill values + ! + integer, parameter :: MPAS_INT_FILLVAL = huge(1) + character, parameter :: MPAS_CHAR_FILLVAL = achar(0) + real (kind=RKIND), parameter :: MPAS_REAL_FILLVAL = huge(1.0_RKIND) + +#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 module procedure MPAS_io_get_var_int0d module procedure MPAS_io_get_var_int1d @@ -103,7 +147,11 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier type (mpas_io_context_type), intent(inout) :: ioContext integer, intent(in) :: io_task_count integer, intent(in) :: io_task_stride +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), optional, pointer :: io_system +#else + integer, optional, pointer :: io_system +#endif integer, intent(out), optional :: ierr integer :: local_ierr @@ -114,7 +162,9 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier if (present(ierr)) ierr = MPAS_IO_NOERR if (present(io_system)) then +#ifdef MPAS_PIO_SUPPORT ioContext % pio_iosystem => io_system +#endif else !call mpas_log_write('MGD PIO_init') if ( io_task_count < 0 .or. io_task_count > ioContext % dminfo % nprocs ) then @@ -140,18 +190,46 @@ subroutine MPAS_io_init(ioContext, io_task_count, io_task_stride, io_system, ier call mpas_log_write('Invalid PIO configuration.', MPAS_LOG_CRIT) end if +#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 PIO_rearr_box, & ! rearr ioContext % pio_iosystem) ! iosystem +#endif + +#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) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_init failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(ioContext % smiol_context)), messageType=MPAS_LOG_CRIT) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_CRIT) + end if + end if +#endif end if +#ifdef MPAS_PIO_SUPPORT call pio_seterrorhandling(ioContext % pio_iosystem, PIO_BCAST_ERROR) +#endif end subroutine MPAS_io_init @@ -212,7 +290,8 @@ subroutine MPAS_io_unset_iotype(ioContext, ierr) end subroutine MPAS_io_unset_iotype - type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioContext, clobber_file, truncate_file, ierr) + type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioContext, & + clobber_file, truncate_file, pio_file_desc, ierr) implicit none @@ -222,11 +301,20 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon type (mpas_io_context_type), pointer :: ioContext logical, intent(in), optional :: clobber_file logical, intent(in), optional :: truncate_file +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, optional :: pio_file_desc +#endif integer, intent(out), optional :: ierr integer :: pio_ierr, pio_iotype, pio_mode + integer :: local_ierr logical :: local_clobber, local_truncate logical :: exists +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: preexisting_records +#endif ! call mpas_log_write('Called MPAS_io_open()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -266,6 +354,7 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon MPAS_io_open % ioformat = ioformat MPAS_io_open % ioContext => ioContext +#ifdef MPAS_PIO_SUPPORT if (ioContext % master_pio_iotype /= -999) then pio_iotype = ioContext % master_pio_iotype pio_mode = PIO_64BIT_OFFSET @@ -288,56 +377,104 @@ type (MPAS_IO_Handle_type) function MPAS_io_open(filename, mode, ioformat, ioCon #endif end if end if +#endif - if (mode == MPAS_IO_WRITE) then + if (present(pio_file_desc)) then +#ifdef MPAS_PIO_SUPPORT + MPAS_io_open % pio_file = pio_file_desc +#endif + MPAS_io_open % external_file_desc = .true. + else + if (mode == MPAS_IO_WRITE) then !call mpas_log_write('MGD PIO_createfile') - if (ioContext % dminfo % my_proc_id == 0) then - inquire(file=trim(filename), exist=exists) - end if - call mpas_dmpar_bcast_logical(ioContext % dminfo, exists) + if (ioContext % dminfo % my_proc_id == 0) then + inquire(file=trim(filename), exist=exists) + end if + call mpas_dmpar_bcast_logical(ioContext % dminfo, exists) - ! If the file exists and we are not allowed to clobber it, return an - ! appropriate error code - if (exists .and. (.not. local_clobber)) then - if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER - return - end if + ! If the file exists and we are not allowed to clobber it, return an + ! appropriate error code + if (exists .and. (.not. local_clobber)) then + if (present(ierr)) ierr = MPAS_IO_ERR_WOULD_CLOBBER + return + end if - if (exists .and. (.not. local_truncate)) then - pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) - MPAS_io_open % preexisting_file = .true. - else - pio_ierr = PIO_createfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), pio_mode) + if (exists .and. (.not. local_truncate)) then +#ifdef MPAS_PIO_SUPPORT + pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_write) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_open_file(ioContext % smiol_context, trim(filename), & + SMIOL_FILE_WRITE, MPAS_io_open % smiol_file) +#endif + MPAS_io_open % preexisting_file = .true. + else +#ifdef MPAS_PIO_SUPPORT + pio_ierr = PIO_createfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), pio_mode) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_open_file(ioContext % smiol_context, trim(filename), & + SMIOL_FILE_CREATE, MPAS_io_open % smiol_file) +#endif #ifdef MPAS_DEBUG - if (exists) then - call mpas_log_write('MPAS I/O: Truncating existing data in output file '//trim(filename), MPAS_LOG_WARN) + if (exists) then + call mpas_log_write('MPAS I/O: Truncating existing data in output file '//trim(filename), MPAS_LOG_WARN) + end if +#endif end if + else + inquire(file=trim(filename), exist=exists) + + if (.not. exists) then + if (present(ierr)) ierr = MPAS_IO_ERR_NOEXIST_READ + return + end if +#ifdef MPAS_PIO_SUPPORT +!call mpas_log_write('MGD PIO_openfile') + pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_open_file(ioContext % smiol_context, trim(filename), & + SMIOL_FILE_READ, MPAS_io_open % smiol_file) #endif + endif +#ifdef MPAS_PIO_SUPPORT + if (pio_ierr /= PIO_noerr) then + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return end if - else - inquire(file=trim(filename), exist=exists) +#endif +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_open_file failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + else + call mpas_log_write(trim(SMIOLf_error_string(local_ierr)), messageType=MPAS_LOG_ERR) + end if - if (.not. exists) then - if (present(ierr)) ierr = MPAS_IO_ERR_NOEXIST_READ + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if -!call mpas_log_write('MGD PIO_openfile') - pio_ierr = PIO_openfile(ioContext % pio_iosystem, MPAS_io_open % pio_file, pio_iotype, trim(filename), PIO_nowrite) - endif - if (pio_ierr /= PIO_noerr) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO - return +#endif + MPAS_io_open % external_file_desc = .false. end if if (mode == MPAS_IO_READ .or. MPAS_io_open % preexisting_file) then +#ifdef MPAS_PIO_SUPPORT !MPAS_io_open % pio_unlimited_dimid = 44 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 +#ifdef MPAS_PIO_SUPPORT ! Here we're depending on the undocumented behavior of PIO to return a ! negative dimension ID when an unlimited dimension is not found. This ! might change in the future, causing this code to break, though it @@ -345,12 +482,19 @@ 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 MPAS_io_open % preexisting_records = -1 end if +#endif +#ifdef MPAS_SMIOL_SUPPORT +!MGD TODO: need a way to determine which dimension is the unlimited dimension + local_ierr = SMIOLf_inquire_dim(MPAS_io_open % smiol_file, 'Time', dimsize=preexisting_records) + MPAS_io_open % preexisting_records = preexisting_records +#endif end if MPAS_io_open % initialized = .true. @@ -383,12 +527,19 @@ subroutine MPAS_io_inq_unlimited_dim(handle, dimname, ierr) return end if +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_dimname(handle % pio_file, handle % pio_unlimited_dimid, dimname) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_NO_UNLIMITED_DIM dimname = ' ' return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT +!MGD TODO: Do this for SMIOL once we have a way to inquire about unlimited dim by name + dimname = 'Time' +#endif end subroutine MPAS_io_inq_unlimited_dim @@ -405,6 +556,10 @@ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr) type (dimlist_type), pointer :: new_dimlist_node type (dimlist_type), pointer :: dim_cursor integer :: pio_ierr + integer :: local_ierr +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: local_dimsize +#endif ! call mpas_log_write('Called MPAS_io_inq_dim()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -438,6 +593,7 @@ subroutine MPAS_io_inq_dim(handle, dimname, dimsize, ierr) new_dimlist_node % dimhandle % dimname = dimname +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_inq_dimid(handle % pio_file, trim(dimname), new_dimlist_node % dimhandle % dimid) if (pio_ierr /= PIO_noerr) then if (present(ierr)) ierr = MPAS_IO_ERR_MISSING_DIM @@ -451,12 +607,28 @@ 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 return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_inquire_dim(handle % smiol_file, trim(dimname), & + dimsize=local_dimsize, & + is_unlimited=new_dimlist_node % dimhandle % is_unlimited_dim) + if (local_ierr /= SMIOL_SUCCESS) then + if (present(ierr)) ierr = MPAS_IO_ERR_MISSING_DIM + deallocate(new_dimlist_node % dimhandle) + deallocate(new_dimlist_node) + dimsize = -1 + return + end if + new_dimlist_node % dimhandle % dimsize = local_dimsize +#endif ! Keep dimension information for future reference if (.not. associated(handle % dimlist_head)) then @@ -484,7 +656,11 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: inq_dimsize +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: local_dimsize +#endif type (dimlist_type), pointer :: new_dimlist_node type (dimlist_type), pointer :: dim_cursor @@ -539,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 @@ -563,16 +739,44 @@ subroutine MPAS_io_def_dim(handle, dimname, dimsize, ierr) new_dimlist_node % dimhandle % dimsize = dimsize if (dimsize == MPAS_IO_UNLIMITED_DIM) then new_dimlist_node % dimhandle % is_unlimited_dim = .true. +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_def_dim(handle % pio_file, trim(dimname), PIO_unlimited, new_dimlist_node % dimhandle % dimid) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_dimsize = -1_SMIOL_offset_kind +#endif else +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_def_dim(handle % pio_file, trim(dimname), dimsize, new_dimlist_node % dimhandle % dimid) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_dimsize = int(dimsize,kind=SMIOL_offset_kind) +#endif + end if +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_define_dim(handle % smiol_file, trim(dimname), local_dimsize) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_dim failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 end if +#endif ! Keep dimension information if (.not. associated(handle % dimlist_head)) then @@ -611,6 +815,13 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz integer, dimension(:), pointer :: dimids logical :: found integer :: pio_ierr + integer :: local_ierr + integer :: smiol_type + integer :: smiol_ndims + character(len=StrKind), dimension(:), allocatable :: smiol_dimnames +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind) :: smiol_dimlen +#endif ! call mpas_log_write('Called MPAS_io_inq_var()') @@ -649,10 +860,12 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz new_fieldlist_node % fieldhandle % fieldname = fieldname ! Get variable ID +#ifdef MPAS_PIO_SUPPORT 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) @@ -663,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 @@ -684,24 +898,78 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz new_fieldlist_node % fieldhandle % field_type = MPAS_IO_CHAR !!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!! end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), vartype=smiol_type) + if (local_ierr /= SMIOL_SUCCESS) then + 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) + return + end if + new_fieldlist_node % fieldhandle % field_type = smiol_type + + ! Convert to MPAS type + new_fieldlist_node % fieldhandle % precision = MPAS_IO_NATIVE_PRECISION + if (new_fieldlist_node % fieldhandle % field_type == SMIOL_REAL64) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_DOUBLE + new_fieldlist_node % fieldhandle % precision = MPAS_IO_DOUBLE_PRECISION + else if (new_fieldlist_node % fieldhandle % field_type == SMIOL_REAL32) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL + new_fieldlist_node % fieldhandle % precision = MPAS_IO_SINGLE_PRECISION + else if (new_fieldlist_node % fieldhandle % field_type == SMIOL_INT32) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_INT + else if (new_fieldlist_node % fieldhandle % field_type == SMIOL_CHAR) then + new_fieldlist_node % fieldhandle % field_type = MPAS_IO_CHAR + end if +#endif ! Get number of dimensions +#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 end if !call mpas_log_write('Inquired about number of dimensions $i', intArgs=(/new_fieldlist_node % fieldhandle % ndims/) ) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), ndims=smiol_ndims) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_inquire_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 + + deallocate(new_fieldlist_node % fieldhandle) + deallocate(new_fieldlist_node) + call mpas_log_write('Variable ' // trim(fieldname) // ' not in input file.', MPAS_LOG_WARN) + return + end if + new_fieldlist_node% fieldhandle % ndims = smiol_ndims +#endif allocate(dimids(new_fieldlist_node % fieldhandle % ndims)) ! Get dimension IDs +#ifdef MPAS_PIO_SUPPORT 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) @@ -709,9 +977,11 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz end if !call mpas_log_write('Inquired about dimension IDs $i.', intArgs=(/dimids/) ) end if +#endif allocate(new_fieldlist_node % fieldhandle % dims(new_fieldlist_node % fieldhandle % ndims)) +#ifdef MPAS_PIO_SUPPORT ! Get information about dimensions do i=1,new_fieldlist_node % fieldhandle % ndims new_fieldlist_node % fieldhandle % dims(i) % dimid = dimids(i) @@ -722,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) @@ -732,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) @@ -741,6 +1013,50 @@ subroutine MPAS_io_inq_var(handle, fieldname, fieldtype, ndims, dimnames, dimsiz !call mpas_log_write('Inquired about dimension name ' // trim(new_fieldlist_node % fieldhandle % dims(i) % dimname)) end do +#endif + +#ifdef MPAS_SMIOL_SUPPORT + new_fieldlist_node % fieldhandle % has_unlimited_dim = .false. + allocate(smiol_dimnames(smiol_ndims)) + local_ierr = SMIOLf_inquire_var(handle % smiol_file, trim(fieldname), dimnames=smiol_dimnames) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_inquire_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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) + end do + do i=1,new_fieldlist_node % fieldhandle % ndims + local_ierr = SMIOLf_inquire_dim(handle % smiol_file, trim(smiol_dimnames(i)), & + dimsize=smiol_dimlen, & + is_unlimited=new_fieldlist_node % fieldhandle % dims(i) % is_unlimited_dim) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_inquire_dim failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 + new_fieldlist_node % fieldhandle % has_unlimited_dim = .true. + end if + end do + deallocate(smiol_dimnames) +#endif deallocate(dimids) @@ -828,7 +1144,9 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie integer :: i integer :: pio_ierr + integer :: local_ierr integer :: pio_type + integer :: smiol_type integer :: ndims integer :: inq_fieldtype integer :: inq_ndims @@ -899,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 @@ -980,41 +1298,92 @@ subroutine MPAS_io_def_var(handle, fieldname, fieldtype, dimnames, precision, ie ! Convert from MPAS type if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_DOUBLE) then if (local_precision == MPAS_IO_SINGLE_PRECISION) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_real +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL32 +#endif new_fieldlist_node % fieldhandle % field_type = MPAS_IO_REAL else +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_double +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL64 +#endif end if else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_REAL) then if (local_precision == MPAS_IO_DOUBLE_PRECISION) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_double +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL64 +#endif new_fieldlist_node % fieldhandle % field_type = MPAS_IO_DOUBLE else +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_real +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_REAL32 +#endif end if else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_INT) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_int +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_INT32 +#endif else if (new_fieldlist_node % fieldhandle % field_type == MPAS_IO_CHAR) then +#ifdef MPAS_PIO_SUPPORT pio_type = PIO_char +#endif +#ifdef MPAS_SMIOL_SUPPORT + smiol_type = SMIOL_CHAR +#endif !!!!!!!! PIO DOES NOT SUPPORT LOGICAL !!!!!!!! end if +#ifdef MPAS_PIO_SUPPORT if (ndims == 0) then pio_ierr = PIO_def_var(handle % pio_file, trim(fieldname), pio_type, new_fieldlist_node % fieldhandle % field_desc) else 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 +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_define_var(handle % smiol_file, trim(fieldname), smiol_type, size(dimnames), dimnames) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 ! Get the varid for use by put_att routines +#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 deallocate(dimids) @@ -1102,6 +1471,11 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) integer, dimension(:), pointer :: dimlist integer (kind=MPAS_IO_OFFSET_KIND), dimension(:), pointer :: compdof type (decomplist_type), pointer :: decomp_cursor, new_decomp +#ifdef MPAS_SMIOL_SUPPORT + integer(kind=SMIOL_offset_kind), dimension(:), pointer :: smiol_indices + integer :: local_ierr + integer(kind=SMIOL_offset_kind) :: smiol_n_compute_elements +#endif ! call mpas_log_write('Called MPAS_io_set_var_indices()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -1147,6 +1521,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) !if (.not. associated(decomp_cursor)) call mpas_log_write('No existing decompositions to check...') early_return = 0 DECOMP_LOOP: do while (associated(decomp_cursor)) +#ifdef MPAS_PIO_SUPPORT if (decomp_cursor % decomphandle % field_type == field_cursor % fieldhandle % field_type) then if (size(decomp_cursor % decomphandle % dims) == field_cursor % fieldhandle % ndims) then !call mpas_log_write('Number of dimensions matches...') @@ -1157,6 +1532,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) cycle DECOMP_LOOP end if end do +#endif if (size(decomp_cursor % decomphandle % indices) /= size(indices)) then !call mpas_log_write('We do not have the same number of indices in this decomposition...') @@ -1177,6 +1553,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) !call mpas_log_write('Found a matching decomposition that we can use') early_return = 1 exit DECOMP_LOOP +#ifdef MPAS_PIO_SUPPORT else if ((size(decomp_cursor % decomphandle % dims) == field_cursor % fieldhandle % ndims - 1) & .and. field_cursor % fieldhandle % has_unlimited_dim & ) then @@ -1212,6 +1589,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) exit DECOMP_LOOP end if end if +#endif decomp_cursor => decomp_cursor % next end do DECOMP_LOOP @@ -1244,6 +1622,7 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) new_decomp % decomphandle % indices(:) = indices(:) ! Convert from MPAS type +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % field_type == MPAS_IO_DOUBLE) then pio_type = PIO_double else if (field_cursor % fieldhandle % field_type == MPAS_IO_REAL) then @@ -1326,6 +1705,30 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) dimlist(ndims) = field_cursor % fieldhandle % dims(ndims) % dimsize call PIO_initdecomp(handle % ioContext % pio_iosystem, pio_type, dimlist, compdof, new_decomp % decomphandle % pio_iodesc) + deallocate(compdof) + deallocate(dimlist) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + allocate(smiol_indices(size(indices))) + smiol_indices(:) = int(indices(:), kind=SMIOL_offset_kind) - 1_SMIOL_offset_kind ! SMIOL indices are 0-based + smiol_n_compute_elements = size(indices,kind=SMIOL_offset_kind) + local_ierr = SMIOLf_create_decomp(handle % ioContext % smiol_context, smiol_n_compute_elements, smiol_indices, & + new_decomp % decomphandle % smiol_decomp) + deallocate(smiol_indices) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_create_decomp failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 ! Add new decomposition to the list if (.not. associated(handle % ioContext % decomp_list)) then @@ -1340,8 +1743,6 @@ subroutine MPAS_io_set_var_indices(handle, fieldname, indices, ierr) !call mpas_log_write('Setting decomp in fieldhandle') field_cursor % fieldhandle % decomp => new_decomp % decomphandle - deallocate(compdof) - deallocate(dimlist) !call mpas_log_write('All finished.') end subroutine MPAS_io_set_var_indices @@ -1355,22 +1756,23 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr type (MPAS_IO_Handle_type), intent(inout) :: handle character (len=*), intent(in) :: fieldname - integer, intent(out), optional :: intVal - integer, dimension(:), intent(out), optional :: intArray1d - integer, dimension(:,:), intent(out), optional :: intArray2d - integer, dimension(:,:,:), intent(out), optional :: intArray3d - integer, dimension(:,:,:,:), intent(out), optional :: intArray4d - real (kind=RKIND), intent(out), optional :: realVal - real (kind=RKIND), dimension(:), intent(out), optional :: realArray1d - real (kind=RKIND), dimension(:,:), intent(out), optional :: realArray2d - real (kind=RKIND), dimension(:,:,:), intent(out), optional :: realArray3d - real (kind=RKIND), dimension(:,:,:,:), intent(out), optional :: realArray4d - real (kind=RKIND), dimension(:,:,:,:,:), intent(out), optional :: realArray5d - character (len=*), intent(out), optional :: charVal - character (len=*), dimension(:), intent(out), optional :: charArray1d + integer, intent(out), target, optional :: intVal + integer, dimension(:), intent(out), target, optional :: intArray1d + integer, dimension(:,:), intent(out), target, optional :: intArray2d + integer, dimension(:,:,:), intent(out), target, optional :: intArray3d + integer, dimension(:,:,:,:), intent(out), target, optional :: intArray4d + real (kind=RKIND), intent(out), target, optional :: realVal + real (kind=RKIND), dimension(:), intent(out), target, optional :: realArray1d + real (kind=RKIND), dimension(:,:), intent(out), target, optional :: realArray2d + real (kind=RKIND), dimension(:,:,:), intent(out), target, optional :: realArray3d + real (kind=RKIND), dimension(:,:,:,:), intent(out), target, optional :: realArray4d + real (kind=RKIND), dimension(:,:,:,:,:), intent(out), target, optional :: realArray5d + character (len=*), intent(out), target, optional :: charVal + character (len=*), dimension(:), intent(out), target, optional :: charArray1d integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer, dimension(1) :: start1 integer, dimension(1) :: count1 integer, dimension(2) :: start2 @@ -1388,19 +1790,44 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr integer i, j - real (kind=R4KIND) :: singleVal - real (kind=R4KIND), dimension(:), allocatable :: singleArray1d - real (kind=R4KIND), dimension(:,:), allocatable :: singleArray2d - real (kind=R4KIND), dimension(:,:,:), allocatable :: singleArray3d - real (kind=R4KIND), dimension(:,:,:,:), allocatable :: singleArray4d - real (kind=R4KIND), dimension(:,:,:,:,:), allocatable :: singleArray5d + real (kind=R4KIND), pointer :: singleVal + real (kind=R4KIND), target :: singleVal_target + real (kind=R4KIND), dimension(:), pointer :: singleArray1d + real (kind=R4KIND), dimension(:,:), pointer :: singleArray2d + real (kind=R4KIND), dimension(:,:,:), pointer :: singleArray3d + real (kind=R4KIND), dimension(:,:,:,:), pointer :: singleArray4d + real (kind=R4KIND), dimension(:,:,:,:,:), pointer :: singleArray5d + + real (kind=R8KIND), pointer :: doubleVal + real (kind=R8KIND), target :: doubleVal_target + real (kind=R8KIND), dimension(:), pointer :: doubleArray1d + real (kind=R8KIND), dimension(:,:), pointer :: doubleArray2d + real (kind=R8KIND), dimension(:,:,:), pointer :: doubleArray3d + real (kind=R8KIND), dimension(:,:,:,:), pointer :: doubleArray4d + real (kind=R8KIND), dimension(:,:,:,:,:), pointer :: doubleArray5d + + integer, pointer :: intVal_p + integer, dimension(:), pointer :: intArray1d_p + integer, dimension(:,:), pointer :: intArray2d_p + integer, dimension(:,:,:), pointer :: intArray3d_p + integer, dimension(:,:,:,:), pointer :: intArray4d_p + real (kind=RKIND), pointer :: realVal_p + real (kind=RKIND), dimension(:), pointer :: realArray1d_p + real (kind=RKIND), dimension(:,:), pointer :: realArray2d_p + real (kind=RKIND), dimension(:,:,:), pointer :: realArray3d_p + real (kind=RKIND), dimension(:,:,:,:), pointer :: realArray4d_p + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: realArray5d_p + character (len=:), pointer :: charVal_p + character (len=:), dimension(:), pointer :: charArray1d_p + +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_decomp), pointer :: null_decomp + + nullify(null_decomp) +#endif - real (kind=R8KIND) :: doubleVal - real (kind=R8KIND), dimension(:), allocatable :: doubleArray1d - real (kind=R8KIND), dimension(:,:), allocatable :: doubleArray2d - real (kind=R8KIND), dimension(:,:,:), allocatable :: doubleArray3d - real (kind=R8KIND), dimension(:,:,:,:), allocatable :: doubleArray4d - real (kind=R8KIND), dimension(:,:,:,:,:), allocatable :: doubleArray5d + singleVal => singleVal_target + doubleVal => doubleVal_target ! Sanity checks if (.not. handle % initialized) then @@ -1430,11 +1857,30 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write('Checking for unlimited dim') if (field_cursor % fieldhandle % has_unlimited_dim) then +#ifdef MPAS_PIO_SUPPORT #ifdef USE_PIO2 call PIO_setframe(handle % pio_file, field_cursor % fieldhandle % field_desc, handle % frame_number) #else call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number) #endif +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_set_frame(handle % smiol_file, int(handle % frame_number - 1, kind=SMIOL_offset_kind)) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_set_frame failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 + start1(1) = handle % frame_number count1(1) = 1 @@ -1448,36 +1894,74 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr ! call mpas_log_write(' value is real') if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleVal) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, singleVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, singleVal) end if +#endif + realVal = real(singleVal,RKIND) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleVal) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, doubleVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, doubleVal) end if +#endif + realVal = real(doubleVal,RKIND) else + realVal_p => realVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realVal_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) end if +#endif end if else if (present(intVal)) then ! call mpas_log_write(' value is int') + + intVal_p => intVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intVal_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, intVal) else pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % field_desc, intVal) end if +#endif else if (present(charVal)) then ! call mpas_log_write(' value is char') + + charVal_p => charVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then count2(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, tempchar) @@ -1488,8 +1972,10 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, tempchar) charVal(1:count1(1)) = tempchar(1)(1:count1(1)) end if +#endif else if (present(charArray1d)) then ! call mpas_log_write(' value is char1') +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then ! Can only read one string at a time, since the sizes differ so much (i.e. StrLen != StrKIND) do i = 1, field_cursor % fieldhandle % dims(2) % dimsize @@ -1533,15 +2019,33 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr end do end do end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d char variables not yet implemented in SMIOL: '//trim(fieldname), messageType=MPAS_LOG_ERR) +#endif + else if (present(realArray1d)) then ! call mpas_log_write(' value is real1') if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray1d(size(realArray1d,1))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1553,6 +2057,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, singleArray1d) end if +#endif end if realArray1d(:) = real(singleArray1d(:),RKIND) deallocate(singleArray1d) @@ -1560,9 +2065,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray1d(size(realArray1d,1))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray1d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1574,14 +2091,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, doubleArray1d) end if +#endif end if realArray1d(:) = real(doubleArray1d(:),RKIND) deallocate(doubleArray1d) else + realArray1d_p => realArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1593,6 +2124,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, realArray1d) end if +#endif end if end if else if (present(realArray2d)) then @@ -1601,9 +2133,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray2d(size(realArray2d,1), size(realArray2d,2))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1617,6 +2161,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, singleArray2d) end if +#endif end if realArray2d(:,:) = real(singleArray2d(:,:),RKIND) deallocate(singleArray2d) @@ -1624,9 +2169,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray2d(size(realArray2d,1), size(realArray2d,2))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray2d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1640,14 +2197,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, doubleArray2d) end if +#endif end if realArray2d(:,:) = real(doubleArray2d(:,:),RKIND) deallocate(doubleArray2d) else + realArray2d_p => realArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1661,6 +2232,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, realArray2d) end if +#endif end if end if else if (present(realArray3d)) then @@ -1669,9 +2241,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray3d(size(realArray3d,1),size(realArray3d,2),size(realArray3d,3))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1687,6 +2271,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, singleArray3d) end if +#endif end if realArray3d(:,:,:) = real(singleArray3d(:,:,:),RKIND) deallocate(singleArray3d) @@ -1694,9 +2279,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray3d(size(realArray3d,1),size(realArray3d,2),size(realArray3d,3))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray3d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1712,14 +2309,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, doubleArray3d) end if +#endif end if realArray3d(:,:,:) = real(doubleArray3d(:,:,:),RKIND) deallocate(doubleArray3d) else + realArray3d_p => realArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1735,6 +2346,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, realArray3d) end if +#endif end if end if else if (present(realArray4d)) then @@ -1743,9 +2355,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray4d(size(realArray4d,1),size(realArray4d,2),size(realArray4d,3),size(realArray4d,4))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1763,6 +2387,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, singleArray4d) end if +#endif end if realArray4d(:,:,:,:) = real(singleArray4d(:,:,:,:),RKIND) deallocate(singleArray4d) @@ -1770,9 +2395,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray4d(size(realArray4d,1),size(realArray4d,2),size(realArray4d,3),size(realArray4d,4))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray4d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1790,14 +2427,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, doubleArray4d) end if +#endif end if realArray4d(:,:,:,:) = real(doubleArray4d(:,:,:,:),RKIND) deallocate(doubleArray4d) else + realArray4d_p => realArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1815,6 +2466,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, realArray4d) end if +#endif end if end if else if (present(realArray5d)) then @@ -1823,9 +2475,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray5d(size(realArray5d,1),size(realArray5d,2),size(realArray5d,3),size(realArray5d,4),size(realArray5d,5))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray5d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(:) = 1 start6(6) = handle % frame_number @@ -1845,6 +2509,7 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, singleArray5d) end if +#endif end if realArray5d(:,:,:,:,:) = real(singleArray5d(:,:,:,:,:),RKIND) deallocate(singleArray5d) @@ -1852,9 +2517,21 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleArray5d(size(realArray5d,1),size(realArray5d,2),size(realArray5d,3),size(realArray5d,4),size(realArray5d,5))) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray5d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray5d) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(:) = 1 start6(6) = handle % frame_number @@ -1874,14 +2551,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, doubleArray5d) end if +#endif end if realArray5d(:,:,:,:,:) = real(doubleArray5d(:,:,:,:,:),RKIND) deallocate(doubleArray5d) else + realArray5d_p => realArray5d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray5d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray5d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, realArray5d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(:) = 1 start6(6) = handle % frame_number @@ -1901,14 +2592,28 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start5, count5, realArray5d) end if +#endif end if end if else if (present(intArray1d)) then ! call mpas_log_write(' value is int1') + intArray1d_p => intArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray1d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray1d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -1920,13 +2625,27 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start1, count1, intArray1d) end if +#endif end if else if (present(intArray2d)) then ! call mpas_log_write(' value is int2') + intArray2d_p => intArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray2d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray2d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(:) = 1 start3(3) = handle % frame_number @@ -1940,13 +2659,27 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start2, count2, intArray2d) end if +#endif end if else if (present(intArray3d)) then ! call mpas_log_write(' value is int3') + intArray3d_p => intArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray3d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray3d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(:) = 1 start4(4) = handle % frame_number @@ -1962,13 +2695,27 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start3, count3, intArray3d) end if +#endif end if else if (present(intArray4d)) then ! call mpas_log_write(' value is int4') + intArray4d_p => intArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT call PIO_read_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray4d, pio_ierr) +#endif else +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_get_var(handle % smiol_file, trim(fieldname), null_decomp, intArray4d_p) +#endif + +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(:) = 1 start5(5) = handle % frame_number @@ -1986,14 +2733,33 @@ subroutine MPAS_io_get_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_get_var(handle % pio_file, field_cursor % fieldhandle % fieldid, start4, count4, intArray4d) end if +#endif end if end if ! 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 + +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_get_var failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 end subroutine MPAS_io_get_var_generic @@ -2187,6 +2953,8 @@ end subroutine MPAS_io_get_var_real5d subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr) + use mpas_c_interfacing, only : MPAS_sanitize_string + implicit none type (MPAS_IO_Handle_type), intent(inout) :: handle @@ -2198,12 +2966,15 @@ subroutine MPAS_io_get_var_char0d(handle, fieldname, val, ierr) if (present(ierr)) ierr = MPAS_IO_NOERR call MPAS_io_get_var_generic(handle, fieldname, charVal=val, ierr=ierr) + call MPAS_sanitize_string(val) end subroutine MPAS_io_get_var_char0d subroutine MPAS_io_get_var_char1d(handle, fieldname, val, ierr) + use mpas_c_interfacing, only : MPAS_sanitize_string + implicit none type (MPAS_IO_Handle_type), intent(inout) :: handle @@ -2211,10 +2982,15 @@ subroutine MPAS_io_get_var_char1d(handle, fieldname, val, ierr) character (len=*), dimension(:), intent(out) :: val integer, intent(out), optional :: ierr + integer :: i + ! call mpas_log_write('Called MPAS_io_get_var_char1d()') if (present(ierr)) ierr = MPAS_IO_NOERR call MPAS_io_get_var_generic(handle, fieldname, charArray1d=val, ierr=ierr) + do i=1,size(val) + call MPAS_sanitize_string(val(i)) + end do end subroutine MPAS_io_get_var_char1d @@ -2253,22 +3029,23 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr type (MPAS_IO_Handle_type), intent(inout) :: handle character (len=*), intent(in) :: fieldname - integer, intent(in), optional :: intVal - integer, dimension(:), intent(in), optional :: intArray1d - integer, dimension(:,:), intent(in), optional :: intArray2d - integer, dimension(:,:,:), intent(in), optional :: intArray3d - integer, dimension(:,:,:,:), intent(in), optional :: intArray4d - real (kind=RKIND), intent(in), optional :: realVal - real (kind=RKIND), dimension(:), intent(in), optional :: realArray1d - real (kind=RKIND), dimension(:,:), intent(in), optional :: realArray2d - real (kind=RKIND), dimension(:,:,:), intent(in), optional :: realArray3d - real (kind=RKIND), dimension(:,:,:,:), intent(in), optional :: realArray4d - real (kind=RKIND), dimension(:,:,:,:,:), intent(in), optional :: realArray5d - character (len=*), intent(in), optional :: charVal - character (len=*), dimension(:), intent(in), optional :: charArray1d + integer, intent(in), target, optional :: intVal + integer, dimension(:), intent(in), target, optional :: intArray1d + integer, dimension(:,:), intent(in), target, optional :: intArray2d + integer, dimension(:,:,:), intent(in), target, optional :: intArray3d + integer, dimension(:,:,:,:), intent(in), target, optional :: intArray4d + real (kind=RKIND), intent(in), target, optional :: realVal + real (kind=RKIND), dimension(:), intent(in), target, optional :: realArray1d + real (kind=RKIND), dimension(:,:), intent(in), target, optional :: realArray2d + real (kind=RKIND), dimension(:,:,:), intent(in), target, optional :: realArray3d + real (kind=RKIND), dimension(:,:,:,:), intent(in), target, optional :: realArray4d + real (kind=RKIND), dimension(:,:,:,:,:), intent(in), target, optional :: realArray5d + character (len=*), intent(in), target, optional :: charVal + character (len=*), dimension(:), intent(in), target, optional :: charArray1d integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer, dimension(1) :: start1 integer, dimension(1) :: count1 integer, dimension(2) :: start2 @@ -2285,19 +3062,44 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr integer :: i - real (kind=R4KIND) :: singleVal - real (kind=R4KIND), dimension(:), allocatable :: singleArray1d - real (kind=R4KIND), dimension(:,:), allocatable :: singleArray2d - real (kind=R4KIND), dimension(:,:,:), allocatable :: singleArray3d - real (kind=R4KIND), dimension(:,:,:,:), allocatable :: singleArray4d - real (kind=R4KIND), dimension(:,:,:,:,:), allocatable :: singleArray5d + real (kind=R4KIND), target :: singleVal_target + real (kind=R4KIND), pointer :: singleVal + real (kind=R4KIND), dimension(:), pointer :: singleArray1d + real (kind=R4KIND), dimension(:,:), pointer :: singleArray2d + real (kind=R4KIND), dimension(:,:,:), pointer :: singleArray3d + real (kind=R4KIND), dimension(:,:,:,:), pointer :: singleArray4d + real (kind=R4KIND), dimension(:,:,:,:,:), pointer :: singleArray5d + + real (kind=R8KIND), target :: doubleVal_target + real (kind=R8KIND), pointer :: doubleVal + real (kind=R8KIND), dimension(:), pointer :: doubleArray1d + real (kind=R8KIND), dimension(:,:), pointer :: doubleArray2d + real (kind=R8KIND), dimension(:,:,:), pointer :: doubleArray3d + real (kind=R8KIND), dimension(:,:,:,:), pointer :: doubleArray4d + real (kind=R8KIND), dimension(:,:,:,:,:), pointer :: doubleArray5d + + integer, pointer :: intVal_p + integer, dimension(:), pointer :: intArray1d_p + integer, dimension(:,:), pointer :: intArray2d_p + integer, dimension(:,:,:), pointer :: intArray3d_p + integer, dimension(:,:,:,:), pointer :: intArray4d_p + real (kind=RKIND), pointer :: realVal_p + real (kind=RKIND), dimension(:), pointer :: realArray1d_p + real (kind=RKIND), dimension(:,:), pointer :: realArray2d_p + real (kind=RKIND), dimension(:,:,:), pointer :: realArray3d_p + real (kind=RKIND), dimension(:,:,:,:), pointer :: realArray4d_p + real (kind=RKIND), dimension(:,:,:,:,:), pointer :: realArray5d_p + character (len=:), pointer :: charVal_p + character (len=:), dimension(:), pointer :: charArray1d_p + +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_decomp), pointer :: null_decomp + + nullify(null_decomp) +#endif - real (kind=R8KIND) :: doubleVal - real (kind=R8KIND), dimension(:), allocatable :: doubleArray1d - real (kind=R8KIND), dimension(:,:), allocatable :: doubleArray2d - real (kind=R8KIND), dimension(:,:,:), allocatable :: doubleArray3d - real (kind=R8KIND), dimension(:,:,:,:), allocatable :: doubleArray4d - real (kind=R8KIND), dimension(:,:,:,:,:), allocatable :: doubleArray5d + singleVal => singleVal_target + doubleVal => doubleVal_target ! Sanity checks if (.not. handle % initialized) then @@ -2308,15 +3110,19 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr if (.not. handle % data_mode) then handle % data_mode = .true. +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_enddef(handle % pio_file) ! If we are working with a preexisting file, we likely didn't define ! new dimensions or variables, in which case PIO_enddef() will return ! an error under harmless circumstances; so, don't return only for ! pre-existing files. - if (pio_ierr /= PIO_noerr .and. (.not. handle % preexisting_file)) then - if (present(ierr)) ierr = MPAS_IO_ERR_PIO + if (pio_ierr /= PIO_noerr .and. & + .not. (handle % external_file_desc .or. handle % preexisting_file)) then + io_global_err = pio_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND return end if +#endif end if ! call mpas_log_write('Writing '//trim(fieldname)) @@ -2338,11 +3144,30 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr if (field_cursor % fieldhandle % has_unlimited_dim) then +#ifdef MPAS_PIO_SUPPORT #ifdef USE_PIO2 call PIO_setframe(handle % pio_file, field_cursor % fieldhandle % field_desc, handle % frame_number) #else call PIO_setframe(field_cursor % fieldhandle % field_desc, handle % frame_number) #endif +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_set_frame(handle % smiol_file, int(handle % frame_number - 1, kind=SMIOL_offset_kind)) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_set_frame failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 + start1(1) = handle % frame_number count1(1) = 1 @@ -2358,33 +3183,60 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then singleVal = real(realVal,R4KIND) +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, singleVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, singleVal) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleVal) +#endif else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then doubleVal = real(realVal,R8KIND) +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, doubleVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, doubleVal) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleVal) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, realVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, realVal) end if +#endif + + realVal_p => realVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realVal_p) +#endif end if else if (present(intVal)) then +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, intVal) else pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, intVal) end if +#endif + + intVal_p => intVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intVal_p) +#endif else if (present(charVal)) then +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then count2(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, charVal(1:count2(1))) @@ -2393,7 +3245,14 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, charVal(1:count1(1))) end if +#endif + + charVal_p => charVal +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, charVal_p) +#endif else if (present(charArray1d)) then +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then ! Write one string at a time because the sizes differ so much (i.e. StrLen != StrKIND) do i = 1, field_cursor % fieldhandle % dims(2) % dimsize @@ -2415,15 +3274,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, charArray1d(i)(1:count2(1))) end do end if +#endif +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d char variables not yet implemented in SMIOL: '//trim(fieldname), messageType=MPAS_LOG_ERR) +#endif else if (present(realArray1d)) then if ((field_cursor % fieldhandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleArray1d(size(realArray1d))) singleArray1d(:) = real(realArray1d(:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray1d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2435,6 +3306,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, singleArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray1d) +#endif end if deallocate(singleArray1d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2442,9 +3318,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray1d(size(realArray1d))) doubleArray1d(:) = real(realArray1d(:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray1d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2456,13 +3340,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, doubleArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray1d) +#endif end if deallocate(doubleArray1d) else + realArray1d_p => realArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray1d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2474,6 +3372,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, realArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray1d_p) +#endif end if end if else if (present(realArray2d)) then @@ -2482,9 +3385,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray2d(size(realArray2d,1), size(realArray2d,2))) singleArray2d(:,:) = real(realArray2d(:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray2d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2499,6 +3410,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, singleArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray2d) +#endif end if deallocate(singleArray2d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2506,9 +3422,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray2d(size(realArray2d,1), size(realArray2d,2))) doubleArray2d(:,:) = real(realArray2d(:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray2d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2523,13 +3447,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, doubleArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray2d) +#endif end if deallocate(doubleArray2d) else + realArray2d_p => realArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray2d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2544,6 +3482,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, realArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray2d_p) +#endif end if end if else if (present(realArray3d)) then @@ -2552,9 +3495,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray3d(size(realArray3d,1), size(realArray3d,2), size(realArray3d,3))) singleArray3d(:,:,:) = real(realArray3d(:,:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray3d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2572,6 +3523,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, singleArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray3d) +#endif end if deallocate(singleArray3d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2579,9 +3535,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray3d(size(realArray3d,1), size(realArray3d,2), size(realArray3d,3))) doubleArray3d(:,:,:) = real(realArray3d(:,:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray3d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2599,13 +3563,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, doubleArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray3d) +#endif end if deallocate(doubleArray3d) else + realArray3d_p => realArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray3d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2623,6 +3601,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, realArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray3d_p) +#endif end if end if else if (present(realArray4d)) then @@ -2631,9 +3614,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray4d(size(realArray4d,1), size(realArray4d,2), size(realArray4d,3), size(realArray4d,4))) singleArray4d(:,:,:,:) = real(realArray4d(:,:,:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray4d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2654,6 +3645,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, singleArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray4d) +#endif end if deallocate(singleArray4d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2661,9 +3657,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray4d(size(realArray4d,1), size(realArray4d,2), size(realArray4d,3), size(realArray4d,4))) doubleArray4d(:,:,:,:) = real(realArray4d(:,:,:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray4d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2684,13 +3688,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, doubleArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray4d) +#endif end if deallocate(doubleArray4d) else + realArray4d_p => realArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray4d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2711,6 +3729,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, realArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray4d_p) +#endif end if end if else if (present(realArray5d)) then @@ -2719,9 +3742,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(singleArray5d(size(realArray5d,1), size(realArray5d,2), size(realArray5d,3), size(realArray5d,4), size(realArray5d,5))) singleArray5d(:,:,:,:,:) = real(realArray5d(:,:,:,:,:),R4KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & singleArray5d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, singleArray5d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(1) = 1 start6(2) = 1 @@ -2745,6 +3776,11 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, singleArray5d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, singleArray5d) +#endif end if deallocate(singleArray5d) else if ((field_cursor % fieldhandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -2752,9 +3788,17 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr allocate(doubleArray5d(size(realArray5d,1), size(realArray5d,2), size(realArray5d,3), size(realArray5d,4), size(realArray5d,5))) doubleArray5d(:,:,:,:,:) = real(realArray5d(:,:,:,:,:),R8KIND) if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & doubleArray5d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, doubleArray5d) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(1) = 1 start6(2) = 1 @@ -2778,13 +3822,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, doubleArray5d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, doubleArray5d) +#endif end if deallocate(doubleArray5d) else + realArray5d_p => realArray5d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & realArray5d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, realArray5d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start6(1) = 1 start6(2) = 1 @@ -2808,13 +3866,27 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count5(5) = field_cursor % fieldhandle % dims(5) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start5, count5, realArray5d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, realArray5d_p) +#endif end if end if else if (present(intArray1d)) then + intArray1d_p => intArray1d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray1d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray1d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start2(1) = 1 start2(2) = handle % frame_number @@ -2826,12 +3898,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count1(1) = field_cursor % fieldhandle % dims(1) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start1, count1, intArray1d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray1d_p) +#endif end if else if (present(intArray2d)) then + intArray2d_p => intArray2d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray2d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray2d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start3(1) = 1 start3(2) = 1 @@ -2846,12 +3932,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count2(2) = field_cursor % fieldhandle % dims(2) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start2, count2, intArray2d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray2d_p) +#endif end if else if (present(intArray3d)) then + intArray3d_p => intArray3d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray3d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray3d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start4(1) = 1 start4(2) = 1 @@ -2869,12 +3969,26 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count3(3) = field_cursor % fieldhandle % dims(3) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start3, count3, intArray3d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray3d_p) +#endif end if else if (present(intArray4d)) then + intArray4d_p => intArray4d if (associated(field_cursor % fieldhandle % decomp)) then +#ifdef MPAS_PIO_SUPPORT call PIO_write_darray(handle % pio_file, field_cursor % fieldhandle % field_desc, field_cursor % fieldhandle % decomp % pio_iodesc, & intArray4d, pio_ierr) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), & + field_cursor % fieldhandle % decomp % smiol_decomp, intArray4d_p) +#endif else +#ifdef MPAS_PIO_SUPPORT if (field_cursor % fieldhandle % has_unlimited_dim) then start5(1) = 1 start5(2) = 1 @@ -2895,12 +4009,34 @@ subroutine MPAS_io_put_var_generic(handle, fieldname, intVal, intArray1d, intArr count4(4) = field_cursor % fieldhandle % dims(4) % dimsize pio_ierr = PIO_put_var(handle % pio_file, field_cursor % fieldhandle % field_desc, start4, count4, intArray4d) end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_put_var(handle % smiol_file, trim(fieldname), null_decomp, intArray4d_p) +#endif end if 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 +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_put_var failed with error $i : '//trim(fieldname), intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 end subroutine MPAS_io_put_var_generic @@ -3137,6 +4273,7 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: xtype #ifdef USE_PIO2 @@ -3206,13 +4343,17 @@ subroutine MPAS_io_get_att_int0d(handle, attName, attValue, fieldname, ierr) att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if ! Query attribute value +#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 @@ -3222,9 +4363,29 @@ 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 + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), attValue) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), attValue) + end if + if (local_ierr /= SMIOL_SUCCESS) then + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE + return + else + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return + end if + end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3295,6 +4456,9 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d integer attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif ! ! For variable attributes, find the structure for fieldname @@ -3347,13 +4511,17 @@ subroutine MPAS_io_get_att_int1d(handle, attName, attValue, fieldname, ierr) att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if ! Query attribute value +#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 @@ -3364,16 +4532,19 @@ 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 ! Keep attribute for future reference allocate(new_att_node) @@ -3427,6 +4598,7 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: local_precision real (kind=R4KIND) :: singleVal @@ -3499,7 +4671,9 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if if (present(precision)) then @@ -3508,10 +4682,12 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio local_precision = MPAS_IO_NATIVE_PRECISION end if +#ifdef MPAS_PIO_SUPPORT ! 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 @@ -3523,6 +4699,7 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio return end if pio_ierr = PIO_get_att(handle % pio_file, varid, attName, singleVal) + attValue = real(singleVal,RKIND) else if ((local_precision == MPAS_IO_DOUBLE_PRECISION) .and. & @@ -3533,6 +4710,7 @@ subroutine MPAS_io_get_att_real0d(handle, attName, attValue, fieldname, precisio return end if pio_ierr = PIO_get_att(handle % pio_file, varid, attName, doubleVal) + attValue = real(doubleVal,RKIND) else @@ -3545,9 +4723,76 @@ 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 + +#ifdef MPAS_SMIOL_SUPPORT + ! + ! Try to read the attribute in the MPAS native precision + ! + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), & + trim(attName), attValue) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', & + trim(attName), attValue) + end if + + ! + ! If that fails, perhaps the attribute is in a different precision from + ! the native MPAS precision + ! + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (MPAS_IO_NATIVE_PRECISION == MPAS_IO_DOUBLE_PRECISION) then + + ! + ! Try again, but read a single-precision value + ! + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), & + trim(attName), singleVal) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', & + trim(attName), singleVal) + end if + attValue = real(singleVal,RKIND) + + else + + ! + ! Try again, but read a double-precision value + ! + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), & + trim(attName), doubleVal) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', & + trim(attName), doubleVal) + end if + attValue = real(doubleVal,RKIND) + + end if + end if + + ! + ! If all of the above were unsuccessful, set attValue to a fill value + ! and return an error + ! + if (local_ierr /= SMIOL_SUCCESS) then + attValue = MPAS_REAL_FILLVAL + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE + else + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return + end if return end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3623,6 +4868,9 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d real attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif ! ! For variable attributes, find the structure for fieldname @@ -3675,7 +4923,9 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if if (present(precision)) then @@ -3685,15 +4935,18 @@ subroutine MPAS_io_get_att_real1d(handle, attName, attValue, fieldname, precisio end if ! Query attribute value +#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 @@ -3734,9 +4987,11 @@ 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 ! Keep attribute for future reference allocate(new_att_node) @@ -3790,6 +5045,7 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: xtype #ifdef USE_PIO2 @@ -3859,13 +5115,17 @@ subroutine MPAS_io_get_att_text(handle, attName, attValue, fieldname, ierr) att_cursor => att_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif end if ! Query attribute value +#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 @@ -3875,9 +5135,29 @@ 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 + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_inquire_att(handle % smiol_file, trim(fieldname), trim(attName), attValue) + else + local_ierr = SMIOLf_inquire_att(handle % smiol_file, '', trim(attName), attValue) + end if + if (local_ierr /= SMIOL_SUCCESS) then + if (local_ierr == SMIOL_WRONG_ARG_TYPE) then + if (present(ierr)) ierr = MPAS_IO_ERR_WRONG_ATT_TYPE + return + else + io_global_err = local_ierr + if (present(ierr)) ierr = MPAS_IO_ERR_BACKEND + return + end if + end if +#endif ! Keep attribute for future reference allocate(new_att_node) @@ -3930,6 +5210,7 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: attValueLocal type (fieldlist_type), pointer :: field_cursor @@ -4031,7 +5312,9 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4054,11 +5337,34 @@ subroutine MPAS_io_put_att_int0d(handle, attName, attValue, fieldname, syncVal, end if end if +#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 + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), attValueLocal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), attValueLocal) + end if + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_att failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 ! Maybe we should add attribute to list only after a successfull call to PIO? @@ -4102,6 +5408,9 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d integer attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif allocate(new_attlist_node) nullify(new_attlist_node % next) @@ -4188,7 +5497,9 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4211,11 +5522,14 @@ subroutine MPAS_io_put_att_int1d(handle, attName, attValue, fieldname, syncVal, end if end if +#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 deallocate(attValueLocal) @@ -4237,6 +5551,7 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid real (kind=RKIND) :: attValueLocal real (kind=R4KIND) :: singleVal @@ -4345,7 +5660,9 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4371,19 +5688,66 @@ subroutine MPAS_io_put_att_real0d(handle, attName, attValue, fieldname, syncVal, if ((new_attlist_node % attHandle % precision == MPAS_IO_SINGLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then singleVal = real(attValueLocal,R4KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, singleVal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), singleVal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), singleVal) + end if +#endif else if ((new_attlist_node % attHandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then doubleVal = real(attValueLocal,R8KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, doubleVal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), doubleVal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), doubleVal) + end if +#endif else +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), attValueLocal) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), attValueLocal) + end if +#endif 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 +#ifdef MPAS_SMIOL_SUPPORT + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_att failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 ! Maybe we should add attribute to list only after a successfull call to PIO? @@ -4431,6 +5795,9 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, return end if +#ifdef MPAS_SMIOL_SUPPORT + call mpas_log_write('1-d real attributes not yet implemented in SMIOL: '//trim(attName), messageType=MPAS_LOG_ERR) +#endif allocate(new_attlist_node) nullify(new_attlist_node % next) @@ -4522,7 +5889,9 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4549,21 +5918,30 @@ subroutine MPAS_io_put_att_real1d(handle, attName, attValue, fieldname, syncVal, (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_SINGLE_PRECISION)) then allocate(singleVal(size(attValueLocal))) singleVal(:) = real(attValueLocal(:),R4KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, singleVal) +#endif deallocate(singleVal) else if ((new_attlist_node % attHandle % precision == MPAS_IO_DOUBLE_PRECISION) .and. & (MPAS_IO_NATIVE_PRECISION /= MPAS_IO_DOUBLE_PRECISION)) then allocate(doubleVal(size(attValueLocal))) doubleVal(:) = real(attValueLocal(:),R8KIND) +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, doubleVal) +#endif deallocate(doubleVal) else +#ifdef MPAS_PIO_SUPPORT pio_ierr = PIO_put_att(handle % pio_file, varid, attName, attValueLocal) +#endif 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 deallocate(attValueLocal) @@ -4584,6 +5962,7 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr integer :: varid integer :: valLen character (len=StrKind) :: attValueLocal, trimmedVal @@ -4695,7 +6074,9 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i attlist_cursor => attlist_cursor % next end do +#ifdef MPAS_PIO_SUPPORT varid = PIO_global +#endif ! Add attribute to global attribute list if (.not. associated(handle % attlist_head)) then @@ -4718,10 +6099,12 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i end if end if +#ifdef MPAS_PIO_SUPPORT 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 @@ -4732,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 @@ -4751,6 +6137,27 @@ subroutine MPAS_io_put_att_text(handle, attName, attValue, fieldname, syncVal, i return end if +#endif + +#ifdef MPAS_SMIOL_SUPPORT + if (present(fieldname)) then + local_ierr = SMIOLf_define_att(handle % smiol_file, trim(fieldname), trim(attName), trim(attValueLocal)) + else + local_ierr = SMIOLf_define_att(handle % smiol_file, '', trim(attName), trim(attValueLocal)) + end if + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_define_att failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 ! Maybe we should add attribute to list only after a successfull call to PIO? @@ -4795,6 +6202,8 @@ subroutine MPAS_io_sync(handle, ierr) type (MPAS_IO_Handle_type), intent(inout) :: handle integer, intent(out), optional :: ierr + integer :: local_ierr + ! call mpas_log_write('Called MPAS_io_sync()') if (present(ierr)) ierr = MPAS_IO_NOERR @@ -4804,7 +6213,25 @@ subroutine MPAS_io_sync(handle, ierr) return end if +#ifdef MPAS_PIO_SUPPORT call PIO_syncfile(handle % pio_file) +#endif + +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_sync_file(handle % smiol_file) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_sync_file failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 end subroutine MPAS_io_sync @@ -4816,6 +6243,8 @@ subroutine MPAS_io_close(handle, ierr) type (MPAS_IO_Handle_type), intent(inout) :: handle integer, intent(out), optional :: ierr + integer :: local_ierr + type (dimlist_type), pointer :: dimlist_ptr, dimlist_del type (fieldlist_type), pointer :: fieldlist_ptr, fieldlist_del type (attlist_type), pointer :: attlist_ptr, attlist_del @@ -4876,7 +6305,26 @@ subroutine MPAS_io_close(handle, ierr) handle % initialized = .false. !call mpas_log_write('MGD PIO_closefile') - call PIO_closefile(handle % pio_file) + if (.not. handle % external_file_desc) then +#ifdef MPAS_PIO_SUPPORT + call PIO_closefile(handle % pio_file) +#endif + end if +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_close_file(handle % smiol_file) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_close_file failed with error $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + if (local_ierr == SMIOL_LIBRARY_ERROR) then + call mpas_log_write(trim(SMIOLf_lib_error_string(handle % ioContext % smiol_context)), messageType=MPAS_LOG_ERR) + 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 end subroutine MPAS_io_close @@ -4890,6 +6338,7 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) integer, intent(out), optional :: ierr integer :: pio_ierr + integer :: local_ierr type (decomplist_type), pointer :: decomp_cursor, decomp_del ! call mpas_log_write('Called MPAS_io_finalize()') @@ -4903,7 +6352,15 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) !if (.not. associated(decomp_del % decomphandle)) call mpas_log_write('OOPS... do not have decomphandle') deallocate(decomp_del % decomphandle % dims) deallocate(decomp_del % decomphandle % indices) +#ifdef MPAS_PIO_SUPPORT call PIO_freedecomp(ioContext % pio_iosystem, decomp_del % decomphandle % pio_iodesc) +#endif +#ifdef MPAS_SMIOL_SUPPORT + local_ierr = SMIOLf_free_decomp(decomp_del % decomphandle % smiol_decomp) + if (local_ierr /= SMIOL_SUCCESS) then + call mpas_log_write('SMIOLf_free_decomp failed with code $i', intArgs=[local_ierr], messageType=MPAS_LOG_ERR) + end if +#endif deallocate(decomp_del % decomphandle) deallocate(decomp_del) end do @@ -4911,12 +6368,24 @@ subroutine MPAS_io_finalize(ioContext, finalize_iosystem, ierr) !call mpas_log_write('MGD PIO_finalize') if (present(finalize_iosystem)) then if ( finalize_iosystem ) then +#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) +#endif +#ifdef MPAS_SMIOL_SUPPORT + 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 end if @@ -4934,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 ... @@ -4952,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 a7e8b53937..b445d5881a 100644 --- a/src/framework/mpas_io_streams.F +++ b/src/framework/mpas_io_streams.F @@ -78,7 +78,7 @@ module mpas_io_streams subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, precision, & - clobberRecords, clobberFiles, truncateFiles, ierr) + clobberRecords, clobberFiles, truncateFiles, pio_file_desc, ierr) implicit none @@ -91,6 +91,11 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, logical, intent(in), optional :: clobberRecords logical, intent(in), optional :: clobberFiles logical, intent(in), optional :: truncateFiles +#ifdef MPAS_PIO_SUPPORT + type (file_desc_t), intent(inout), optional :: pio_file_desc +#else + integer, optional :: pio_file_desc +#endif integer, intent(out), optional :: ierr integer :: io_err @@ -99,7 +104,7 @@ subroutine MPAS_createStream(stream, ioContext, fileName, ioFormat, ioDirection, stream % fileHandle = MPAS_io_open(fileName, ioDirection, ioFormat, ioContext, clobber_file=clobberFiles, truncate_file=truncateFiles, & - ierr=io_err) + pio_file_desc=pio_file_desc, ierr=io_err) ! ! Catch a few special errors ! @@ -113,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 @@ -148,12 +153,12 @@ integer function MPAS_seekStream(stream, seekTime, seekPosition, actualTime, max integer :: io_err integer :: i integer :: timeDim - character (len=StrKIND), dimension(:), pointer :: xtimes - character (len=StrKIND) :: strTemp + character (len=ShortStrKIND), dimension(:), pointer :: xtimes + character (len=ShortStrKIND) :: strTemp type (MPAS_Time_type) :: sliceTime, startTime type (MPAS_TimeInterval_type) :: timeDiff, minTimeDiff - character (len=StrKIND) :: xtime0, xtime1, xtime2, xtimeGuess + character (len=ShortStrKIND) :: xtime0, xtime1, xtime2, xtimeGuess type (MPAS_Time_type) :: time0, time1, time2, timeGuess, timeGuessData type (MPAS_TimeInterval_type) :: timeInterval @@ -1510,10 +1515,10 @@ subroutine MPAS_streamAddField_0dChar(stream, field, ierr) idim = ndims allocate(indices(0)) allocate(dimSizes(1)) - dimSizes(1) = 64 + dimSizes(1) = ShortStrKIND dimNames(1) = 'StrLen' - globalDimSize = 64 - totalDimSize = 64 + globalDimSize = ShortStrKIND + totalDimSize = ShortStrKIND if (field % isVarArray) then @@ -1602,7 +1607,7 @@ subroutine MPAS_streamAddField_1dChar(stream, field, ierr) idim = ndims allocate(indices(1)) allocate(dimSizes(2)) - dimSizes(1) = 64 + dimSizes(1) = ShortStrKIND dimNames(1) = 'StrLen' dimSizes(2) = field % dimSizes(1) dimNames(2) = field % dimNames(1) @@ -1699,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) @@ -1724,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) @@ -1738,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) @@ -1754,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) @@ -1767,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) @@ -1825,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) @@ -2474,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 @@ -2495,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 @@ -2527,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 @@ -2603,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 @@ -2685,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 @@ -2755,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 @@ -2787,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 @@ -2864,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 @@ -2949,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 @@ -3036,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 @@ -3126,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 @@ -3197,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 @@ -3220,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) @@ -3297,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 @@ -3339,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 @@ -3396,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 @@ -3459,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 @@ -3526,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 @@ -3547,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 @@ -3604,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 @@ -3667,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 @@ -3734,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 @@ -3803,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 @@ -3874,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 @@ -3893,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 @@ -3905,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 @@ -3944,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 @@ -3972,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 @@ -4008,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 @@ -4044,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 @@ -4072,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 @@ -4101,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 @@ -4130,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 @@ -4167,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 @@ -4204,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 @@ -4233,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 @@ -4260,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 6cb61723e6..522e6e1ad5 100644 --- a/src/framework/mpas_io_types.inc +++ b/src/framework/mpas_io_types.inc @@ -1,9 +1,19 @@ +#ifdef MPAS_PIO_SUPPORT #ifdef USE_PIO2 integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET_KIND #else integer, parameter :: MPAS_IO_OFFSET_KIND = PIO_OFFSET #endif +#else + +#ifdef MPAS_SMIOL_SUPPORT + integer, parameter :: MPAS_IO_OFFSET_KIND = SMIOL_offset_kind +#else + integer, parameter :: MPAS_IO_OFFSET_KIND = I8KIND +#endif +#endif + ! File access modes integer, parameter :: MPAS_IO_READ = 1, & MPAS_IO_WRITE = 2 @@ -39,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, & @@ -61,7 +71,13 @@ logical :: initialized = .false. logical :: preexisting_file = .false. logical :: data_mode = .false. + logical :: external_file_desc = .false. +#ifdef MPAS_PIO_SUPPORT type (file_desc_t) :: pio_file +#endif +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_file), pointer :: smiol_file => null() +#endif character (len=StrKIND) :: filename integer :: iomode integer :: ioformat @@ -81,7 +97,12 @@ integer :: field_type integer, dimension(:), pointer :: dims integer, dimension(:), pointer :: indices +#ifdef MPAS_PIO_SUPPORT type (io_desc_t) :: pio_iodesc +#endif +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_decomp), pointer :: smiol_decomp => null() +#endif end type decomphandle_type type atthandle_type @@ -105,7 +126,9 @@ type fieldhandle_type character (len=StrKIND) :: fieldname integer :: fieldid +#ifdef MPAS_PIO_SUPPORT type (Var_desc_t) :: field_desc +#endif integer :: field_type logical :: has_unlimited_dim = .false. integer :: ndims @@ -138,7 +161,12 @@ type mpas_io_context_type type (decomplist_type), pointer :: decomp_list => null() +#ifdef MPAS_PIO_SUPPORT type (iosystem_desc_t), pointer :: pio_iosystem => null() +#endif +#ifdef MPAS_SMIOL_SUPPORT + type (SMIOLf_context), pointer :: smiol_context => null() +#endif integer :: master_pio_iotype = -999 type (dm_info), pointer :: dminfo => null() end type mpas_io_context_type diff --git a/src/framework/mpas_io_units.F b/src/framework/mpas_io_units.F index 579c8ffc23..acd3403b03 100644 --- a/src/framework/mpas_io_units.F +++ b/src/framework/mpas_io_units.F @@ -21,8 +21,19 @@ module mpas_io_units use mpas_kind_types - integer, parameter, private :: maxUnits = 99 - logical, dimension(0:maxUnits), private, save :: unitsInUse + implicit none + + private + + integer, parameter :: maxUnits = 200 + logical, dimension(0:maxUnits), save :: unitsInUse + + ! Units reserved for unformatted I/O + integer, parameter :: unformatted_min = 101 + integer, parameter :: unformatted_max = maxUnits + + public :: mpas_new_unit, & + mpas_release_unit contains @@ -38,14 +49,30 @@ module mpas_io_units !> the unit number ! !----------------------------------------------------------------------- - subroutine mpas_new_unit(newUnit)!{{{ + subroutine mpas_new_unit(newUnit, unformatted)!{{{ + integer, intent(inout) :: newUnit + logical, optional, intent(in) :: unformatted - integer :: i + integer :: i, minsearch, maxsearch logical :: opened - do i = 1, maxUnits + newUnit = -1 + + ! + ! Determine the range over which to search for an unused unit + ! + minsearch = 1 + maxsearch = unformatted_min - 1 + if ( present(unformatted) ) then + if ( unformatted ) then + minsearch = unformatted_min + maxsearch = unformatted_max + end if + end if + + do i = minsearch, maxsearch if (.not. unitsInUse(i)) then inquire(i, opened=opened) if (opened) then @@ -72,9 +99,12 @@ end subroutine mpas_new_unit!}}} ! !----------------------------------------------------------------------- subroutine mpas_release_unit(releasedUnit)!{{{ + integer, intent(in) :: releasedUnit - unitsInUse(releasedUnit) = .false. + if (0 <= releasedUnit .and. releasedUnit <= maxUnits) then + unitsInUse(releasedUnit) = .false. + end if end subroutine mpas_release_unit!}}} diff --git a/src/framework/mpas_log.F b/src/framework/mpas_log.F index eca3b43e82..2b7bbaec22 100644 --- a/src/framework/mpas_log.F +++ b/src/framework/mpas_log.F @@ -41,6 +41,7 @@ module mpas_log use mpas_derived_types use mpas_abort, only : mpas_dmpar_global_abort + use mpas_io_units, only : mpas_new_unit, mpas_release_unit implicit none private @@ -97,8 +98,6 @@ module mpas_log subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) - use mpas_io_units - !----------------------------------------------------------------- ! input variables !----------------------------------------------------------------- @@ -120,6 +119,7 @@ subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) ! local variables !----------------------------------------------------------------- character(len=16) :: taskString !< variable to build the task number as a string with appropriate zero padding + character(len=4) :: domainString !< variable to store the domain number as a string with appropriate zero padding integer :: unitNumber !< local variable used to get a unit number character(len=strKind) :: proposedLogFileName, proposedErrFileName logical :: isOpen @@ -176,6 +176,10 @@ subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) mpas_log_info % taskID = domain % dminfo % my_proc_id mpas_log_info % nTasks = domain % dminfo % nprocs + ! Store the domain number + ! This will be used to number the log files + mpas_log_info % domainID = domain % domainID + ! Set log file to be active or not based on master/nonmaster task and optimized/debug build ! * Optimized build: Only master task log is active ! * Debug build: All tasks active @@ -207,8 +211,17 @@ subroutine mpas_log_init(coreLogInfo, domain, unitNumbers, err) else write(taskString, '(i9.9)') mpas_log_info % taskID end if - write(proposedLogFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".out" - write(proposedErrFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".err" + + if ( mpas_log_info % domainID > 0 ) then + write(domainString, '(i4.4)') mpas_log_info % domainID + write(proposedLogFileName, fmt='(a, a, a, a, a, a, a)') & + "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".d", trim(domainString), ".out" + write(proposedErrFileName, fmt='(a, a, a, a, a, a, a)') & + "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".d", trim(domainString), ".err" + else + write(proposedLogFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".out" + write(proposedErrFileName, fmt='(a, a, a, a, a)') "log.", trim(mpas_log_info % coreName), ".", trim(taskString), ".err" + end if ! Set the log and err file names and unit numbers if (present(unitNumbers)) then @@ -420,6 +433,9 @@ subroutine mpas_log_open(openErrorFile, err) write(unitNumber, '(a)') '----------------------------------------------------------------------' write(unitNumber, '(a,a,a,a,a,i7.1,a,i7.1)') 'Beginning MPAS-', trim(mpas_log_info % coreName), ' ', & trim(logTypeString), ' Log File for task ', mpas_log_info % taskID, ' of ', mpas_log_info % nTasks + if ( mpas_log_info % domainID > 0 ) then + write(unitNumber, '(a,i7.1)') ' for domain ID ', mpas_log_info % domainID + end if call date_and_time(date,time) write(unitNumber, '(a)') ' Opened at ' // date(1:4)//'/'//date(5:6)//'/'//date(7:8) // & ' ' // time(1:2)//':'//time(3:4)//':'//time(5:6) @@ -461,7 +477,7 @@ end subroutine mpas_log_open ! !----------------------------------------------------------------------- - subroutine mpas_log_write(message, messageType, masterOnly, flushNow, & + recursive subroutine mpas_log_write(message, messageType, masterOnly, flushNow, & intArgs, realArgs, logicArgs, err) use mpas_threading @@ -694,6 +710,7 @@ subroutine mpas_log_finalize(err) ! 2) the log mgr opened the file (otherwise the driver that opened it should close it) if (mpas_log_info % outputLog % isActive .and. mpas_log_info % outputLog % openedByLogModule) then close(mpas_log_info % outputLog % unitNum, iostat = err) + call mpas_release_unit(mpas_log_info % outputLog % unitNum) endif ! Note: should not need to close an err file. If these are open, they are intended to quickly lead to abort @@ -791,8 +808,12 @@ subroutine log_abort() #ifdef _MPI #ifndef NOMPIMOD +#ifdef MPAS_USE_MPI_F08 + use mpi_f08, only : MPI_COMM_WORLD, MPI_Abort +#else use mpi #endif +#endif #endif implicit none @@ -823,6 +844,7 @@ subroutine log_abort() ! Close the err log to be clean close(mpas_log_info % errorLog % unitNum) + call mpas_release_unit(mpas_log_info % errorLog % unitNum) deallocate(mpas_log_info % errorLog) deallocate(mpas_log_info % outputLog) diff --git a/src/framework/mpas_log_types.inc b/src/framework/mpas_log_types.inc index 28c018be17..34ba091a56 100644 --- a/src/framework/mpas_log_types.inc +++ b/src/framework/mpas_log_types.inc @@ -27,6 +27,7 @@ integer :: nTasks !< number of total tasks associated with this instance !< (stored here to eliminate the need for dminfo later) character(len=StrKIND) :: coreName !< name of the core to which this log manager instance belongs + integer :: domainID !< domain number for this instance of the log manager integer :: outputMessageCount !< counter for number of output messages printed during the run integer :: warningMessageCount !< counter for number of warning messages printed during the run diff --git a/src/framework/mpas_pool_routines.F b/src/framework/mpas_pool_routines.F index 6d99e56be3..aab1818c30 100644 --- a/src/framework/mpas_pool_routines.F +++ b/src/framework/mpas_pool_routines.F @@ -209,7 +209,7 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ integer :: i, j type (mpas_pool_member_type), pointer :: ptr type (mpas_pool_data_type), pointer :: dptr - integer :: local_err, threadNum + integer :: threadNum threadNum = mpas_threading_get_thread_num() @@ -224,9 +224,9 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ if (ptr % contentsType == MPAS_POOL_DIMENSION) then if (ptr % data % contentsDims > 0) then - deallocate(ptr % data % simple_int_arr, stat=local_err) + deallocate(ptr % data % simple_int_arr) else - deallocate(ptr % data % simple_int, stat=local_err) + deallocate(ptr % data % simple_int) end if else if (ptr % contentsType == MPAS_POOL_CONFIG) then @@ -234,13 +234,13 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ dptr => ptr % data if (dptr % contentsType == MPAS_POOL_REAL) then - deallocate(dptr % simple_real, stat=local_err) + deallocate(dptr % simple_real) else if (dptr % contentsType == MPAS_POOL_INTEGER) then - deallocate(dptr % simple_int, stat=local_err) + deallocate(dptr % simple_int) else if (dptr % contentsType == MPAS_POOL_CHARACTER) then - deallocate(dptr % simple_char, stat=local_err) + deallocate(dptr % simple_char) else if (dptr % contentsType == MPAS_POOL_LOGICAL) then - deallocate(dptr % simple_logical, stat=local_err) + deallocate(dptr % simple_logical) end if else if (ptr % contentsType == MPAS_POOL_FIELD) then @@ -249,138 +249,96 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ ! Do this through brute force... if (associated(dptr % r0)) then - deallocate(dptr % r0, stat=local_err) + call mpas_deallocate_field(dptr % r0) else if (associated(dptr % r1)) then - if (associated(dptr % r1 % array)) then - deallocate(dptr % r1 % array, stat=local_err) - end if - - deallocate(dptr % r1, stat=local_err) + call mpas_deallocate_field(dptr % r1) else if (associated(dptr % r2)) then - if (associated(dptr % r2 % array)) then - deallocate(dptr % r2 % array, stat=local_err) - end if - - deallocate(dptr % r2, stat=local_err) + call mpas_deallocate_field(dptr % r2) else if (associated(dptr % r3)) then - if (associated(dptr % r3 % array)) then - deallocate(dptr % r3 % array, stat=local_err) - end if - - deallocate(dptr % r3, stat=local_err) + call mpas_deallocate_field(dptr % r3) else if (associated(dptr % r4)) then - if (associated(dptr % r4 % array)) then - deallocate(dptr % r4 % array, stat=local_err) - end if - - deallocate(dptr % r4, stat=local_err) + call mpas_deallocate_field(dptr % r4) else if (associated(dptr % r5)) then - if (associated(dptr % r5 % array)) then - deallocate(dptr % r5 % array, stat=local_err) - end if - - deallocate(dptr % r5, stat=local_err) + call mpas_deallocate_field(dptr % r5) else if (associated(dptr % i0)) then - deallocate(dptr % i0, stat=local_err) + call mpas_deallocate_field(dptr % i0) else if (associated(dptr % i1)) then - if (associated(dptr % i1 % array)) then - deallocate(dptr % i1 % array, stat=local_err) - end if - - deallocate(dptr % i1, stat=local_err) + call mpas_deallocate_field(dptr % i1) else if (associated(dptr % i2)) then - if (associated(dptr % i2 % array)) then - deallocate(dptr % i2 % array, stat=local_err) - end if - - deallocate(dptr % i2, stat=local_err) + call mpas_deallocate_field(dptr % i2) else if (associated(dptr % i3)) then - if (associated(dptr % i3 % array)) then - deallocate(dptr % i3 % array, stat=local_err) - end if - - deallocate(dptr % i3, stat=local_err) + call mpas_deallocate_field(dptr % i3) else if (associated(dptr % c0)) then - deallocate(dptr % c0, stat=local_err) + call mpas_deallocate_field(dptr % c0) else if (associated(dptr % c1)) then - if (associated(dptr % c1 % array)) then - deallocate(dptr % c1 % array, stat=local_err) - end if - - deallocate(dptr % c1, stat=local_err) + call mpas_deallocate_field(dptr % c1) else if (associated(dptr % l0)) then - deallocate(dptr % l0, stat=local_err) + call mpas_deallocate_field(dptr % l0) else if (associated(dptr % r0a)) then - deallocate(dptr % r0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % r0a(j)) + end do + deallocate(dptr % r0a) else if (associated(dptr % r1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r1a(j) % array)) then - deallocate(dptr % r1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r1a(j)) end do - deallocate(dptr % r1a, stat=local_err) + deallocate(dptr % r1a) else if (associated(dptr % r2a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r2a(j) % array)) then - deallocate(dptr % r2a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r2a(j)) end do - deallocate(dptr % r2a, stat=local_err) + deallocate(dptr % r2a) else if (associated(dptr % r3a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r3a(j) % array)) then - deallocate(dptr % r3a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r3a(j)) end do - deallocate(dptr % r3a, stat=local_err) + deallocate(dptr % r3a) else if (associated(dptr % r4a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r4a(j) % array)) then - deallocate(dptr % r4a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r4a(j)) end do - deallocate(dptr % r4a, stat=local_err) + deallocate(dptr % r4a) else if (associated(dptr % r5a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % r5a(j) % array)) then - deallocate(dptr % r5a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % r5a(j)) end do - deallocate(dptr % r5a, stat=local_err) + deallocate(dptr % r5a) else if (associated(dptr % i0a)) then - deallocate(dptr % i0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % i0a(j)) + end do + deallocate(dptr % i0a) else if (associated(dptr % i1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i1a(j) % array)) then - deallocate(dptr % i1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % i1a(j)) end do - deallocate(dptr % i1a, stat=local_err) + deallocate(dptr % i1a) else if (associated(dptr % i2a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i2a(j) % array)) then - deallocate(dptr % i2a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % i2a(j)) end do - deallocate(dptr % i2a, stat=local_err) + deallocate(dptr % i2a) else if (associated(dptr % i3a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % i3a(j) % array)) then - deallocate(dptr % i3a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % i3a(j)) end do - deallocate(dptr % i3a, stat=local_err) + deallocate(dptr % i3a) else if (associated(dptr % c0a)) then - deallocate(dptr % c0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % c0a(j)) + end do + deallocate(dptr % c0a) else if (associated(dptr % c1a)) then do j=1,dptr % contentsTimeLevs - if (associated(dptr % c1a(j) % array)) then - deallocate(dptr % c1a(j) % array, stat=local_err) - end if + call mpas_deallocate_field_target(dptr % c1a(j)) end do - deallocate(dptr % c1a, stat=local_err) + deallocate(dptr % c1a) else if (associated(dptr % l0a)) then - deallocate(dptr % l0a, stat=local_err) + do j=1,dptr % contentsTimeLevs + call mpas_deallocate_field_target(dptr % l0a(j)) + end do + deallocate(dptr % l0a) else call pool_mesg('While destroying pool, member '//trim(ptr % key)//' has no valid field pointers.') end if @@ -390,14 +348,14 @@ recursive subroutine mpas_pool_destroy_pool(inPool)!{{{ call mpas_pool_destroy_pool(ptr % data % p) end if - deallocate(ptr % data, stat=local_err) - deallocate(ptr, stat=local_err) + deallocate(ptr % data) + deallocate(ptr) end do end do - deallocate(inPool % table, stat=local_err) - deallocate(inPool, stat=local_err) + deallocate(inPool % table) + deallocate(inPool) end if end subroutine mpas_pool_destroy_pool!}}} @@ -710,7 +668,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % r0) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % r0a(dptr % contentsTimeLevs), newmem % data % r0) newmem % data % r0a(j) = newmem % data % r0 deallocate(newmem % data % r0) @@ -728,7 +686,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % r1) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % r1a(dptr % contentsTimeLevs), newmem % data % r1) newmem % data % r1a(j) = newmem % data % r1 deallocate(newmem % data % r1) @@ -746,7 +704,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % r2) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % r2a(dptr % contentsTimeLevs), newmem % data % r2) newmem % data % r2a(j) = newmem % data % r2 deallocate(newmem % data % r2) @@ -764,7 +722,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % r3) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % r3a(dptr % contentsTimeLevs), newmem % data % r3) newmem % data % r3a(j) = newmem % data % r3 deallocate(newmem % data % r3) @@ -782,7 +740,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % r4) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % r4a(dptr % contentsTimeLevs), newmem % data % r4) newmem % data % r4a(j) = newmem % data % r4 deallocate(newmem % data % r4) @@ -800,7 +758,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % r5) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % r5a(dptr % contentsTimeLevs), newmem % data % r5) newmem % data % r5a(j) = newmem % data % r5 deallocate(newmem % data % r5) @@ -818,7 +776,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % i0) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % i0a(dptr % contentsTimeLevs), newmem % data % i0) newmem % data % i0a(j) = newmem % data % i0 deallocate(newmem % data % i0) @@ -836,7 +794,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % i1) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % i1a(dptr % contentsTimeLevs), newmem % data % i1) newmem % data % i1a(j) = newmem % data % i1 deallocate(newmem % data % i1) @@ -854,7 +812,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % i2) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % i2a(dptr % contentsTimeLevs), newmem % data % i2) newmem % data % i2a(j) = newmem % data % i2 deallocate(newmem % data % i2) @@ -872,7 +830,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % i3) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % i3a(dptr % contentsTimeLevs), newmem % data % i3) newmem % data % i3a(j) = newmem % data % i3 deallocate(newmem % data % i3) @@ -890,7 +848,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % c0) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % c0a(dptr % contentsTimeLevs), newmem % data % c0) newmem % data % c0a(j) = newmem % data % c0 deallocate(newmem % data % c0) @@ -908,7 +866,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % c1) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % c1a(dptr % contentsTimeLevs), newmem % data % c1) newmem % data % c1a(j) = newmem % data % c1 deallocate(newmem % data % c1) @@ -926,7 +884,7 @@ recursive subroutine mpas_pool_clone_pool(srcPool, destPool, overrideTimeLevels) deallocate(newmem % data % l0) end do - do j = minTimeLevels, newmem % data % contentsTimeLevs + do j = minTimeLevels+1, newmem % data % contentsTimeLevs call mpas_duplicate_field(dptr % l0a(dptr % contentsTimeLevs), newmem % data % l0) newmem % data % l0a(j) = newmem % data % l0 deallocate(newmem % data % l0) @@ -1861,7 +1819,7 @@ recursive subroutine mpas_pool_link_parinfo(block, inPool)!{{{ end if else if (poolItr % nDims == 4) then if (poolItr % nTimeLevels > 1) then - decompType = pool_get_member_decomp_type(poolMem % r4 % dimNames(4)) + decompType = pool_get_member_decomp_type(poolMem % r4a(1) % dimNames(4)) if (decompType == MPAS_DECOMP_CELLS) then do i = 1, poolItr % nTimeLevels @@ -3271,7 +3229,7 @@ subroutine mpas_pool_get_field_info(inPool, key, info)!{{{ info % isActive = .false. endl = len_trim(key) - call pool_hash(hash, key, endl) + call pool_hash(hash, key) hash = mod(hash, inPool % size) + 1 @@ -5142,7 +5100,7 @@ subroutine mpas_pool_add_subpool(inPool, key, subPool)!{{{ type (mpas_pool_type), intent(inout) :: inPool character (len=*), intent(in) :: key - type (mpas_pool_type), intent(in), target :: subPool + type (mpas_pool_type), pointer :: subPool type (mpas_pool_member_type), pointer :: newmem @@ -5703,7 +5661,7 @@ logical function pool_add_member(inPool, key, newmem)!{{{ integer :: hash, oldLevel type (mpas_pool_member_type), pointer :: ptr - call pool_hash(hash, trim(newmem % key), newmem % keylen) + call pool_hash(hash, trim(newmem % key)) hash = mod(hash, inPool % size) + 1 @@ -5762,7 +5720,7 @@ function pool_get_member(inPool, key, memType)!{{{ nullify(pool_get_member) endl = len_trim(key) - call pool_hash(hash, key, endl) + call pool_hash(hash, key) hash = mod(hash, inPool % size) + 1 @@ -5797,7 +5755,7 @@ logical function pool_remove_member(inPool, key, memType)!{{{ threadNum = mpas_threading_get_thread_num() endl = len_trim(key) - call pool_hash(hash, key, endl) + call pool_hash(hash, key) hash = mod(hash, inPool % size) + 1 @@ -5992,5 +5950,30 @@ integer function pool_get_member_decomp_type(dimName) result(decompType)!{{{ end function pool_get_member_decomp_type!}}} + subroutine pool_hash(hash, key)!{{{ + + use iso_c_binding, only : c_int, c_char + use mpas_c_interfacing, only : mpas_f_to_c_string + + implicit none + + interface + subroutine c_pool_hash(hash, key) bind(c) + use iso_c_binding, only : c_int, c_char + integer (c_int), intent(inout) :: hash + character (c_char), dimension(*), intent(in) :: key + end subroutine c_pool_hash + end interface + + integer (c_int), intent(inout) :: hash + character(len=*), intent(in) :: key + + character(kind=c_char), dimension(StrKIND+1) :: c_key + + call mpas_f_to_c_string(key, c_key) + call c_pool_hash(hash, c_key) + + end subroutine pool_hash!}}} + end module mpas_pool_routines 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 a74c0d643e..d00fcaa800 100644 --- a/src/framework/mpas_stream_manager.F +++ b/src/framework/mpas_stream_manager.F @@ -47,6 +47,23 @@ module mpas_stream_manager MPAS_get_stream_filename, & MPAS_build_stream_filename + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + ! IMPORTANT NOTE for {pre,post}write_reindex + ! + ! Caution is needed if calling the {pre,post}write_reindex routines directly + ! from outside of the stream manager. These two routines make use of module + ! state to save and retrieve pointers to the original indexing arrays. Problems + ! can arise, for example, if external code calls prewrite_reindex, then makes + ! a call to write output streams via the stream manager: in this case, pointers + ! set by the external call to prewrite_reindex will be overwritten by the + ! internal call to prewrite_reindex within mpas_stream_mgr_write. + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + public :: prewrite_reindex, & ! Please see note above... + postwrite_reindex, & ! Please see note above... + postread_reindex + private interface MPAS_stream_mgr_set_property @@ -104,6 +121,11 @@ subroutine MPAS_stream_mgr_init(manager, ioContext, clock, allFields, allPackage implicit none + interface + subroutine seed_random() bind(c) + end subroutine seed_random + end interface + character (len=*), parameter :: sub = 'MPAS_stream_mgr_init' type (MPAS_streamManager_type), pointer :: manager @@ -3042,6 +3064,8 @@ end subroutine MPAS_stream_mgr_block_write !}}} !----------------------------------------------------------------------- subroutine write_stream(manager, stream, blockID, timeLevel, mgLevel, forceWritenow, writeTime, ierr) !{{{ + use mpas_dmpar, only : IO_NODE + implicit none type (MPAS_streamManager_type), intent(inout) :: manager @@ -3149,7 +3173,10 @@ subroutine write_stream(manager, stream, blockID, timeLevel, mgLevel, forceWrite STREAM_DEBUG_WRITE(' -- Cobber mode is overwrite or append...') ! Check if the file exists - inquire(file=trim(stream % filename), exist=recordSeek) + if (manager % ioContext % dminfo % my_proc_id == IO_NODE) then + inquire(file=trim(stream % filename), exist=recordSeek) + end if + call mpas_dmpar_bcast_logical(manager % ioContext % dminfo, recordSeek) end if ! @@ -3232,7 +3259,10 @@ subroutine write_stream(manager, stream, blockID, timeLevel, mgLevel, forceWrite STREAM_DEBUG_WRITE(' -- Cobber mode is overwrite or append...') ! Check if the file exists - inquire(file=trim(stream % filename), exist=recordSeek) + if (manager % ioContext % dminfo % my_proc_id == IO_NODE) then + inquire(file=trim(stream % filename), exist=recordSeek) + end if + call mpas_dmpar_bcast_logical(manager % ioContext % dminfo, recordSeek) end if stream % nRecords = 1 @@ -3333,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 ! @@ -3543,6 +3573,8 @@ end subroutine MPAS_stream_mgr_read !}}} !----------------------------------------------------------------------- subroutine read_stream(manager, stream, timeLevel, mgLevel, forceReadNow, when, whence, actualWhen, ierr) !{{{ + use mpas_dmpar, only : IO_NODE + implicit none type (MPAS_streamManager_type), intent(inout) :: manager @@ -3808,13 +3840,18 @@ subroutine read_stream(manager, stream, timeLevel, mgLevel, forceReadNow, when, STREAM_DEBUG_WRITE(' --- Retesting filename is ' // trim(test_filename)) - inquire(file=trim(test_filename), exist=retestFile) + if (manager % ioContext % dminfo % my_proc_id == IO_NODE) then + inquire(file=trim(test_filename), exist=retestFile) + end if + call mpas_dmpar_bcast_logical(manager % ioContext % dminfo, retestFile) ! If file exists, the testing stream needs to be built. if ( retestFile ) then call mpas_createStream(testStream, manager % ioContext, test_filename, stream % io_type, MPAS_IO_READ, precision=stream % precision, ierr=local_ierr) else STREAM_DEBUG_WRITE(' Filename: ' // trim(test_filename) // ' does not exist.') + ierr = MPAS_STREAM_MGR_ERROR + return end if end if @@ -3936,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 !}}} @@ -4148,8 +4186,19 @@ end subroutine mpas_build_stream_filename !}}} !----------------------------------------------------------------------- subroutine build_stream(stream, direction, allFields, allPackages, timeLevelIn, mgLevelIn, ierr) !{{{ + use iso_c_binding, only : c_int, c_char + use mpas_c_interfacing, only : mpas_c_to_f_string + implicit none + interface + subroutine gen_random(len, id) bind(c) + use iso_c_binding, only : c_int, c_char + integer (c_int), intent(in), value :: len + character (c_char), dimension(*), intent(inout) :: id + end subroutine gen_random + end interface + type (MPAS_stream_list_type), intent(inout) :: stream integer, intent(in) :: direction type (MPAS_Pool_type), intent(in) :: allFields @@ -4184,8 +4233,9 @@ subroutine build_stream(stream, direction, allFields, allPackages, timeLevelIn, integer :: local_ierr - integer, parameter :: idLength = 10 - character (len=idLength) :: file_id + integer (c_int), parameter :: idLength = 10 + character(len=idLength) :: f_file_id + character(kind=c_char), dimension(idLength+1) :: c_file_id character (len=StrKIND), pointer :: packages logical :: active_field @@ -4228,8 +4278,9 @@ subroutine build_stream(stream, direction, allFields, allPackages, timeLevelIn, ! ! Generate file_id and write to stream ! - call gen_random(idLength, file_id) - call mpas_writeStreamAtt(stream % stream, 'file_id', file_id, syncVal=.true., ierr=local_ierr) + call gen_random(idLength, c_file_id) + call mpas_c_to_f_string(c_file_id, f_file_id) + call mpas_writeStreamAtt(stream % stream, 'file_id', f_file_id, syncVal=.true., ierr=local_ierr) if (local_ierr /= MPAS_STREAM_NOERR) then ierr = MPAS_STREAM_MGR_ERROR return @@ -4596,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 @@ -4617,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 @@ -4627,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 @@ -4781,14 +4858,24 @@ end function is_decomposed_dim !}}} !> indexed fields in module variables *_save, and allocate new arrays for !> the fields, which are set to contain global indices. !> This routine should be called immediately before a write of a stream. + !> + !> IMPORTANT NOTE: Before calling this routine from outside of the stream + !> manager module, please read the "IMPORTANT NOTE" near + !> 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 + integer, parameter :: UNUSED_CELL = 0 + integer, parameter :: UNUSED_EDGE = 0 + 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 @@ -4811,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 @@ -4840,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 @@ -4901,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)) @@ -4909,7 +5023,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ cellsOnCell % array(j,i) = indexToCellID % array(cellsOnCell_ptr % array(j,i)) end do - cellsOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nCells+1 + cellsOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = UNUSED_CELL end do cellsOnCell => cellsOnCell % next @@ -4921,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)) @@ -4929,7 +5044,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ edgesOnCell % array(j,i) = indexToEdgeID % array(edgesOnCell_ptr % array(j,i)) end do - edgesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nEdges+1 + edgesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = UNUSED_EDGE end do edgesOnCell => edgesOnCell % next @@ -4941,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)) @@ -4949,7 +5065,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ verticesOnCell % array(j,i) = indexToVertexID % array(verticesOnCell_ptr % array(j,i)) end do - verticesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = nVertices+1 + verticesOnCell % array(nEdgesOnCell%array(i)+1:maxEdges,i) = UNUSED_VERTEX end do verticesOnCell => verticesOnCell % next @@ -4961,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)) @@ -4978,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)) @@ -4995,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)) @@ -5003,7 +5122,7 @@ subroutine prewrite_reindex(allFields, streamFields) !{{{ edgesOnEdge % array(j,i) = indexToEdgeID % array(edgesOnEdge_ptr % array(j,i)) end do - edgesOnEdge % array(nEdgesOnEdge%array(i)+1:maxEdges2,i) = nEdges+1 + edgesOnEdge % array(nEdgesOnEdge%array(i)+1:maxEdges2,i) = UNUSED_EDGE end do edgesOnEdge => edgesOnEdge % next @@ -5015,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)) @@ -5033,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)) @@ -5076,6 +5197,10 @@ end subroutine prewrite_reindex !}}} !> !> NB: Even if the write of a stream fails, it is important to stil call !> this routine to reset the connectivity fields to contain local indices. + !> + !> IMPORTANT NOTE: Before calling this routine from outside of the stream + !> manager module, please read the "IMPORTANT NOTE" near + !> the top of this module where this routine is made public. ! !----------------------------------------------------------------------- subroutine postwrite_reindex(allFields, streamFields) !{{{ @@ -5149,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) @@ -5157,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) @@ -5165,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) @@ -5173,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) @@ -5181,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) @@ -5189,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) @@ -5197,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) @@ -5205,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) @@ -5250,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 @@ -5270,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) @@ -5282,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) @@ -5303,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) @@ -5319,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) @@ -5335,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) @@ -5351,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) @@ -5367,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) @@ -5383,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) @@ -5399,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 c6de8f0aed..93fdb86336 100644 --- a/src/framework/mpas_timekeeping.F +++ b/src/framework/mpas_timekeeping.F @@ -12,14 +12,9 @@ module mpas_timekeeping use mpas_dmpar use mpas_threading use mpas_log + use mpas_string_utils, only : mpas_split_string use ESMF - use ESMF_BaseMod - use ESMF_Stubs - use ESMF_CalendarMod - use ESMF_ClockMod - use ESMF_TimeMod - use ESMF_TimeIntervalMod private :: mpas_calibrate_alarms private :: mpas_in_ringing_envelope @@ -98,18 +93,31 @@ subroutine mpas_timekeeping_init(calendar) if (trim(calendar) == 'gregorian') then TheCalendar = MPAS_GREGORIAN #ifndef MPAS_NO_ESMF_INIT +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_GREGORIAN) +#else + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_GREGORIAN) +#endif #endif else if (trim(calendar) == 'gregorian_noleap') then TheCalendar = MPAS_GREGORIAN_NOLEAP #ifndef MPAS_NO_ESMF_INIT +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_NOLEAP) +#else + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_NOLEAP) +#endif #endif -! else if (trim(calendar) == '360day') then -! TheCalendar = MPAS_360DAY -!#ifndef MPAS_NO_ESMF_INIT + else if (trim(calendar) == '360day') then + TheCalendar = MPAS_360DAY +#ifndef MPAS_NO_ESMF_INIT +#ifndef MPAS_EXTERNAL_ESMF_LIB ! call ESMF_Initialize(defaultCalendar=ESMF_CALKIND_360DAY) -!#endif + call mpas_log_write('mpas_timekeeping_init: 360-day calendar not supported with the built-in ESMF timekeeping library', MPAS_LOG_ERR) +#else + call ESMF_Initialize(defaultCalKind=ESMF_CALKIND_360DAY) +#endif +#endif else call mpas_log_write('mpas_timekeeping_init: Invalid calendar type', MPAS_LOG_ERR) end if @@ -153,7 +161,14 @@ subroutine mpas_timekeeping_set_year_width(yearWidthIn)!{{{ yearWidth = yearWidthIn + ! + ! The external ESMF library does not provide the ESMF_setYearWidth subroutine, + ! though this may not be a problem, since the library appears to return time strings + ! with as many digits as are needed to represent the year. + ! +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_setYearWidth(yearWidthIn) +#endif end subroutine mpas_timekeeping_set_year_width!}}} @@ -1291,9 +1306,28 @@ subroutine mpas_get_time(curr_time, YYYY, MM, DD, DoY, H, M, S, S_n, S_d, dateTi character (len=StrKIND), intent(out), optional :: dateTimeString integer, intent(out), optional :: ierr + integer :: idx + call ESMF_TimeGet(curr_time % t, YY=YYYY, MM=MM, DD=DD, H=H, M=M, S=S, Sn=S_n, Sd=S_d, rc=ierr) call ESMF_TimeGet(curr_time % t, dayOfYear=DoY, rc=ierr) +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_TimeGet(curr_time % t, timeString=dateTimeString, rc=ierr) +#else + call ESMF_TimeGet(curr_time % t, timeStringISOFrac=dateTimeString, rc=ierr) +#endif + + ! + ! In case an external ESMF library that returns ISO timestamps is being used, + ! convert a 'T' (if it exists in the string) to an '_' to match the format + ! used throughout MPAS + ! + if (present(dateTimeString)) then + idx = index(dateTimeString, 'T') + if (idx > 0) then + dateTimeString(idx:idx) = '_' + end if + end if + if (present(ierr)) then if (ierr == ESMF_SUCCESS) ierr = 0 end if @@ -1334,6 +1368,9 @@ subroutine mpas_set_timeInterval(interval, YY, MM, DD, H, M, S, S_n, S_d, S_i8, character (len=StrKIND) :: timeSubString character (len=StrKIND) :: secDecSubString character(len=StrKIND), pointer, dimension(:) :: subStrings + character(len=16) :: fmtString + integer :: iwidth + integer :: idecimals ! if (present(DD)) then ! days = DD @@ -1403,8 +1440,29 @@ subroutine mpas_set_timeInterval(interval, YY, MM, DD, H, M, S, S_n, S_d, S_i8, if (present(timeString) .or. present(dt)) then - if(present(dt)) then - write (timeString_,*) "00:00:", dt + if (present(dt)) then + ! + ! Before writing dt into a timeString, first construct an appropriate format string + ! + + ! Number of decimal places of precision (9 = nanosecond precision) + idecimals = 9 + + ! Scale total width of representation based on max(log10(dt),0.0) + ! (+2 for at least a leading zero and a '.') + if (dt /= 0.0_RKIND) then + iwidth = int(max(log10(abs(dt)),0.0_RKIND)) + idecimals + 2 + else + iwidth = idecimals + 2 + end if + + ! Add an extra character for a minus sign if needed + if (dt < 0.0_RKIND) then + iwidth = iwidth + 1 + end if + + write(fmtString, '(a,i2.2,a,i2.2,a)') '(a,f', iwidth, '.', idecimals, ')' + write(timeString_,trim(fmtString)) '00:00:', dt else timeString_ = timeString end if @@ -1544,21 +1602,38 @@ subroutine mpas_get_timeInterval(interval, StartTimeIn, DD, H, M, S, S_n, S_d, S real (kind=RKIND), intent(out), optional :: dt integer, intent(out), optional :: ierr - integer :: days, sn, sd + integer :: days, sn, sd, hours, minutes integer (kind=I8KIND) :: seconds + real (kind=R8KIND) :: seconds_real + character (len=1) :: neg + integer :: local_ierr if (present(StartTimeIn)) then call ESMF_TimeIntervalGet(interval % ti, StartTimeIn=StartTimeIn%t, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=ierr) else +#ifndef MPAS_EXTERNAL_ESMF_LIB if ( interval % ti % YR /= 0 .or. interval % ti % MM /= 0 ) then if (present(ierr)) ierr = 1 call mpas_log_write('mpas_get_timeInterval cannnot return time interval information for an interval containing ' // & 'months and years without a startTimeIn argument.', MPAS_LOG_ERR) return end if - call ESMF_TimeIntervalGet(interval % ti, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=ierr) +#endif + call ESMF_TimeIntervalGet(interval % ti, D=days, S_i8=seconds, Sn=sn, Sd=sd, rc=local_ierr) + if (present(ierr)) ierr = local_ierr +#ifdef MPAS_EXTERNAL_ESMF_LIB + ! + ! With an external ESMF library, treat the time interval type as opaque, and just + ! assume that a non-success error code will be returned if the interval cannot be retrieved. + ! + if (local_ierr /= ESMF_SUCCESS) then + call mpas_log_write('mpas_get_timeInterval cannnot return time interval information for an interval containing ' // & + 'months and years without a startTimeIn argument.', MPAS_LOG_ERR) + return + end if +#endif endif if (sd == 0) then ! may only occur if (sn == 0)? @@ -1606,7 +1681,31 @@ subroutine mpas_get_timeInterval(interval, StartTimeIn, DD, H, M, S, S_n, S_d, S end if if (present(timeString)) then +#ifndef MPAS_EXTERNAL_ESMF_LIB call ESMF_TimeIntervalGet(interval % ti, timeString=timeString, rc=ierr) +#else + ! + ! In case an external ESMF library is being used, the time interval may be returned in + ! ISO period format, in which case it is easier to build a time interval string in MPAS + ! format given days, hours, minutes, and seconds. + ! + call ESMF_TimeIntervalGet(interval % ti, StartTimeIn=StartTimeIn%t, & + d=days, h=hours, m=minutes, s_i8=seconds, sN=sn, sD=sd, rc=ierr) + seconds_real = real(seconds,kind=R8KIND) + (real(sn, kind=R8KIND) / real(sd, kind=R8KIND)) + + ! + ! If the time interval is negative, the ESMF library will return negative values for + ! non-zero components of the interval, so days, hours, minutes, and seconds_real must + ! be checked in order to determine whether a '-' needs to be prepended to the timeString + ! + neg = '' + if (days < 0 .or. hours < 0 .or. minutes < 0 .or. seconds_real < 0.0_R8KIND) then + neg = '-' + end if + + write(timeString,'(a,i9.9,a,i2.2,a,i2.2,a,i2.2,f10.9)') trim(neg), abs(days), '_', abs(hours), ':', abs(minutes), ':', & + int(abs(seconds_real)), abs(seconds_real) - int(abs(seconds_real)) +#endif end if if (present(ierr)) then @@ -1692,7 +1791,21 @@ type (MPAS_TimeInterval_type) function mul_ti_n8(ti, n8) type (MPAS_TimeInterval_type), intent(in) :: ti integer (kind=I8KIND), intent(in) :: n8 +#ifndef MPAS_EXTERNAL_ESMF_LIB mul_ti_n8 % ti = ti % ti * n8 +#else + ! + ! At present, the external ESMF library does not support multiplying a time interval + ! by an 8-byte integer, so we convert to a 4-byte integer whenever possible. + ! However, if the value of the 8-byte integer exceeds what can be represented by + ! a 4-byte integer, stop with a critical error. + ! + if (n8 > huge(int(n8)) .or. n8 < -huge(int(n8))) then + call mpas_log_write('(time interval) * 64-bit integer: integer out of range for external ESMF library', & + messageType=MPAS_LOG_CRIT) + end if + mul_ti_n8 % ti = ti % ti * int(n8) +#endif end function mul_ti_n8 @@ -1996,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 @@ -2154,7 +2233,7 @@ subroutine mpas_expand_string(timeStamp, blockID, inString, outString)!{{{ call mpas_set_time(curTime, dateTimeString=timeStamp) - call mpas_get_time(curTime, YYYY=year) + call mpas_get_time(curTime, YYYY=year, MM=month, DD=day, H=hour, M=minute, S=second) write(yearFormat, '(a,i10,a)') '(i0.',yearWidth,')' @@ -2170,15 +2249,12 @@ subroutine mpas_expand_string(timeStamp, blockID, inString, outString)!{{{ if (charExpand) then select case (inString(i:i)) case ('Y') - call mpas_get_time(curTime, YYYY=year) write(timePart, yearFormat) year outString = trim(outString) // trim(timePart) case ('M') - call mpas_get_time(curTime, MM=month) write(timePart, '(i0.2)') month outString = trim(outString) // trim(timePart) case ('D') - call mpas_get_time(curTime, DD=day) write(timePart, '(i0.2)') day outString = trim(outString) // trim(timePart) case ('d') @@ -2186,21 +2262,15 @@ subroutine mpas_expand_string(timeStamp, blockID, inString, outString)!{{{ write(timePart, '(i0.3)') DoY outString = trim(outString) // trim(timePart) case ('h') - call mpas_get_time(curTime, H=hour) write(timePart, '(i0.2)') hour outString = trim(outString) // trim(timePart) case ('m') - call mpas_get_time(curTime, M=minute) write(timePart, '(i0.2)') minute outString = trim(outString) // trim(timePart) case ('s') - call mpas_get_time(curTime, S=second) write(timePart, '(i0.2)') second outString = trim(outString) // trim(timePart) case ('S') - call mpas_get_time(curTime, H=hour) - call mpas_get_time(curTime, M=minute) - call mpas_get_time(curTime, S=second) second = second + 60 * minute + 3600 * hour write(timePart, '(i0.5)') second outString = trim(outString) // trim(timePart) diff --git a/src/framework/pool_hash.c b/src/framework/pool_hash.c index a0930e91ae..ea305d6b05 100644 --- a/src/framework/pool_hash.c +++ b/src/framework/pool_hash.c @@ -1,21 +1,25 @@ -#include +#define NULL_CHARACTER '\0' -#ifdef UNDERSCORE -#define pool_hash pool_hash_ -#else -#ifdef DOUBLEUNDERSCORE -#define pool_hash pool_hash__ -#endif -#endif +/* + use iso_c_binding, only : c_int, c_char -void pool_hash(int* hash, char* key, int* len) + interface + subroutine c_pool_hash(hash, key) bind(c) + use iso_c_binding, only : c_int, c_char + integer (c_int), intent(inout) :: hash + character (c_char), dimension(*), intent(in) :: key + end subroutine c_pool_hash + end interface +*/ + +void c_pool_hash(int* hash, char* key) { int i; unsigned int whash; whash = 0; - for (i=0; i<(*len); i++) { + for (i=0; key[i] != NULL_CHARACTER; i++) { whash += (unsigned int)key[i]; } diff --git a/src/framework/random_id.c b/src/framework/random_id.c index 567bc51887..fdaf3e29d0 100644 --- a/src/framework/random_id.c +++ b/src/framework/random_id.c @@ -9,28 +9,37 @@ #include #include -#ifdef UNDERSCORE -#define gen_random gen_random_ -#define seed_random seed_random_ -#else -#ifdef DOUBLEUNDERSCORE -#define gen_random gen_random__ -#define seed_random seed_random__ -#endif -#endif +/* Use the following interface in Fortran for seed_random() + interface + subroutine seed_random() bind(c) + end subroutine seed_random + end interface + +*/ void seed_random() { srand(time(NULL)); } -void gen_random(int * len, char * id) {/*{{{*/ +/* Use the following interface in Fortran for gen_random() + + interface + subroutine gen_random(len, id) bind(c) + use iso_c_binding, only : c_int, c_char + integer (c_int), intent(in), value :: len + character (c_char), dimension(*), intent(inout) :: id + end subroutine gen_random + end interface + +*/ +void gen_random(int len, char * id) {/*{{{*/ int i; int r; static const char alphanum[] = "0123456789" "abcdefghijklmnopqrstuvwxyz"; - for (i = 0; i < *len; ++i) { + for (i = 0; i < len; ++i) { r = rand(); id[i] = alphanum[r % (sizeof(alphanum) - 1)]; } 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/framework/xml_stream_parser.c b/src/framework/xml_stream_parser.c index 6014b9b738..00b22fd009 100644 --- a/src/framework/xml_stream_parser.c +++ b/src/framework/xml_stream_parser.c @@ -26,9 +26,9 @@ * Interface routines for building streams at run-time; defined in mpas_stream_manager.F */ void stream_mgr_create_stream_c(void *, const char *, int *, const char *, const char *, const char *, const char *, int *, int *, int *, int *, int *); -void mpas_stream_mgr_add_field_c(void *, const char *, const char *, const char *, int *); -void mpas_stream_mgr_add_immutable_stream_fields_c(void *, const char *, const char *, const char *, int *); -void mpas_stream_mgr_add_pool_c(void *, const char *, const char *, const char *, int *); +void stream_mgr_add_field_c(void *, const char *, const char *, const char *, int *); +void stream_mgr_add_immutable_stream_fields_c(void *, const char *, const char *, const char *, int *); +void stream_mgr_add_pool_c(void *, const char *, const char *, const char *, int *); void stream_mgr_add_alarm_c(void *, const char *, const char *, const char *, const char *, int *); void stream_mgr_add_pkg_c(void *, const char *, const char *, int *); diff --git a/src/operators/CMakeLists.txt b/src/operators/CMakeLists.txt new file mode 100644 index 0000000000..5c04339b80 --- /dev/null +++ b/src/operators/CMakeLists.txt @@ -0,0 +1,24 @@ +list(APPEND _mpas_operators_src + mpas_geometry_utils.F + mpas_matrix_operations.F + mpas_rbf_interpolation.F + mpas_spline_interpolation.F + mpas_tensor_operations.F + mpas_tracer_advection_helpers.F + mpas_tracer_advection_mono.F + mpas_tracer_advection_std.F + mpas_vector_operations.F + mpas_vector_reconstruction.F) + +add_library(operators ${_mpas_operators_src}) + +mpas_fortran_target(operators) + +add_library(${PROJECT_NAME}::operators ALIAS operators) + +set_target_properties(operators PROPERTIES OUTPUT_NAME mpas_operators) +target_link_libraries(operators PUBLIC ${PROJECT_NAME}::framework) + +install(TARGETS operators EXPORT ${PROJECT_NAME}Exports + ARCHIVE DESTINATION ${CMAKE_INSTALL_LIBDIR} + LIBRARY DESTINATION ${CMAKE_INSTALL_LIBDIR}) diff --git a/src/operators/mpas_geometry_utils.F b/src/operators/mpas_geometry_utils.F index 7ec62be6cb..1a50a02e60 100644 --- a/src/operators/mpas_geometry_utils.F +++ b/src/operators/mpas_geometry_utils.F @@ -42,9 +42,10 @@ real (kind=RKIND) function mpas_sphere_angle(ax, ay, az, bx, by, bz, cx, cy, cz) real (kind=RKIND) :: s ! Semiperimeter of the triangle real (kind=RKIND) :: sin_angle - a = acos(max(min(bx*cx + by*cy + bz*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (3) - b = acos(max(min(ax*cx + ay*cy + az*cz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (2) - c = acos(max(min(ax*bx + ay*by + az*bz,1.0_RKIND),-1.0_RKIND)) ! Eqn. (1) + + a = mpas_arc_length(bx, by, bz, cx, cy, cz) + b = mpas_arc_length(ax, ay, az, cx, cy, cz) + c = mpas_arc_length(ax, ay, az, bx, by, bz) ABx = bx - ax ABy = by - ay @@ -1728,4 +1729,142 @@ subroutine mpas_spherical_linear_interp(pInterp, p0, p1, alpha) !{{{ end subroutine mpas_spherical_linear_interp !}}} + +!----------------------------------------------------------------------- +! routine mpas_rotate_about_vector +! +!> \brief Rotates a point about a vector in R3 +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Rotates the point (x,y,z) through an angle theta about the vector +!> originating at (a, b, c) and having direction (u, v, w). +! +!> Reference: https://sites.google.com/site/glennmurray/Home/rotation-matrices-and-formulas/rotation-about-an-arbitrary-axis-in-3-dimensions +! +!----------------------------------------------------------------------- + subroutine mpas_rotate_about_vector(x, y, z, theta, a, b, c, u, v, w, xp, yp, zp) + + implicit none + + real (kind=RKIND), intent(in) :: x, y, z, theta, a, b, c, u, v, w + real (kind=RKIND), intent(out) :: xp, yp, zp + + real (kind=RKIND) :: vw2, uw2, uv2 + real (kind=RKIND) :: m + + vw2 = v**2.0 + w**2.0 + uw2 = u**2.0 + w**2.0 + uv2 = u**2.0 + v**2.0 + m = sqrt(u**2.0 + v**2.0 + w**2.0) + + xp = (a*vw2 + u*(-b*v-c*w+u*x+v*y+w*z) + ((x-a)*vw2+u*(b*v+c*w-v*y-w*z))*cos(theta) + m*(-c*v+b*w-w*y+v*z)*sin(theta))/m**2.0 + yp = (b*uw2 + v*(-a*u-c*w+u*x+v*y+w*z) + ((y-b)*uw2+v*(a*u+c*w-u*x-w*z))*cos(theta) + m*( c*u-a*w+w*x-u*z)*sin(theta))/m**2.0 + zp = (c*uv2 + w*(-a*u-b*v+u*x+v*y+w*z) + ((z-c)*uv2+w*(a*u+b*v-u*x-v*y))*cos(theta) + m*(-b*u+a*v-v*x+u*y)*sin(theta))/m**2.0 + + end subroutine mpas_rotate_about_vector + + +!----------------------------------------------------------------------- +! routine mpas_mirror_point +! +!> \brief Finds the "mirror" of a point about a great-circle arc +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Given the endpoints of a great-circle arc (A,B) and a point, computes +!> the location of the point on the opposite side of the arc along a great- +!> circle arc that intersects (A,B) at a right angle, and such that the arc +!> between the point and its mirror is bisected by (A,B). +!> +!> Assumptions: A, B, and the point to be reflected all lie on the surface +!> of the unit sphere. +! +!----------------------------------------------------------------------- + subroutine mpas_mirror_point(xPoint, yPoint, zPoint, xA, yA, zA, xB, yB, zB, xMirror, yMirror, zMirror) + + implicit none + + real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint + real(kind=RKIND), intent(in) :: xA, yA, zA + real(kind=RKIND), intent(in) :: xB, yB, zB + real(kind=RKIND), intent(out) :: xMirror, yMirror, zMirror + + real(kind=RKIND) :: alpha + + ! + ! Find the spherical angle between arcs AP and AB (where P is the point to be reflected) + ! + alpha = mpas_sphere_angle(xA, yA, zA, xPoint, yPoint, zPoint, xB, yB, zB) + + ! + ! Rotate the point to be reflected by twice alpha about the vector from the origin to A + ! + call mpas_rotate_about_vector(xPoint, yPoint, zPoint, 2.0_RKIND * alpha, 0.0_RKIND, 0.0_RKIND, 0.0_RKIND, & + xA, yA, zA, xMirror, yMirror, zMirror) + + end subroutine mpas_mirror_point + + +!----------------------------------------------------------------------- +! routine mpas_in_cell +! +!> \brief Determines whether a point is within a Voronoi cell +!> \author Michael Duda +!> \date 7 March 2019 +!> \details +!> Given a point on the surface of the sphere, the corner points of a Voronoi +!> cell, and the generating point for that Voronoi cell, determines whether +!> the given point is within the Voronoi cell. +! +!----------------------------------------------------------------------- + logical function mpas_in_cell(xPoint, yPoint, zPoint, xCell, yCell, zCell, & + nEdgesOnCell, verticesOnCell, xVertex, yVertex, zVertex) + + implicit none + + real(kind=RKIND), intent(in) :: xPoint, yPoint, zPoint + real(kind=RKIND), intent(in) :: xCell, yCell, zCell + integer, intent(in) :: nEdgesOnCell + integer, dimension(:), intent(in) :: verticesOnCell + real(kind=RKIND), dimension(:), intent(in) :: xVertex, yVertex, zVertex + + integer :: i + integer :: vtx1, vtx2 + real(kind=RKIND) :: xNeighbor, yNeighbor, zNeighbor + real(kind=RKIND) :: inDist, outDist + real(kind=RKIND) :: radius + real(kind=RKIND) :: radius_inv + + radius = sqrt(xCell * xCell + yCell * yCell + zCell * zCell) + radius_inv = 1.0_RKIND / radius + + inDist = mpas_arc_length(xPoint, yPoint, zPoint, xCell, yCell, zCell) + + mpas_in_cell = .true. + + do i=1,nEdgesOnCell + vtx1 = verticesOnCell(i) + vtx2 = verticesOnCell(mod(i,nEdgesOnCell)+1) + + call mpas_mirror_point(xCell*radius_inv, yCell*radius_inv, zCell*radius_inv, & + xVertex(vtx1)*radius_inv, yVertex(vtx1)*radius_inv, zVertex(vtx1)*radius_inv, & + xVertex(vtx2)*radius_inv, yVertex(vtx2)*radius_inv, zVertex(vtx2)*radius_inv, & + xNeighbor, yNeighbor, zNeighbor) + + xNeighbor = xNeighbor * radius + yNeighbor = yNeighbor * radius + zNeighbor = zNeighbor * radius + + outDist = mpas_arc_length(xPoint, yPoint, zPoint, xNeighbor, yNeighbor, zNeighbor) + + if (outDist < inDist) then + mpas_in_cell = .false. + return + end if + + end do + + end function mpas_in_cell + end module mpas_geometry_utils diff --git a/src/operators/mpas_spline_interpolation.F b/src/operators/mpas_spline_interpolation.F index f7fa682842..6d0d2ffa02 100644 --- a/src/operators/mpas_spline_interpolation.F +++ b/src/operators/mpas_spline_interpolation.F @@ -115,6 +115,10 @@ subroutine mpas_interpolate_cubic_spline( &!{{{ ! INPUT PARAMETERS: + integer, intent(in) :: & + n, &!< Input: number of nodes, input grid + nOut !< Input: number of nodes, output grid + real (kind=RKIND), dimension(n), intent(in) :: & x, &!< Input: node location, input grid y, &!< Input: interpolation variable, input grid @@ -123,10 +127,6 @@ subroutine mpas_interpolate_cubic_spline( &!{{{ real (kind=RKIND), dimension(nOut), intent(in) :: & xOut !< Input: node location, output grid - integer, intent(in) :: & - n, &!< Input: number of nodes, input grid - nOut !< Input: number of nodes, output grid - ! OUTPUT PARAMETERS: real (kind=RKIND), dimension(nOut), intent(out) :: & @@ -359,6 +359,10 @@ subroutine mpas_interpolate_linear( &!{{{ ! !INPUT PARAMETERS: + integer, intent(in) :: & + N, &!< Input: number of nodes, input grid + NOut !< Input: number of nodes, output grid + real (kind=RKIND), dimension(n), intent(in) :: & x, &!< Input: node location, input grid y !< Input: interpolation variable, input grid @@ -366,10 +370,6 @@ subroutine mpas_interpolate_linear( &!{{{ real (kind=RKIND), dimension(nOut), intent(in) :: & xOut !< Input: node location, output grid - integer, intent(in) :: & - N, &!< Input: number of nodes, input grid - NOut !< Input: number of nodes, output grid - ! !OUTPUT PARAMETERS: real (kind=RKIND), dimension(nOut), intent(out) :: & diff --git a/src/operators/mpas_tracer_advection_helpers.F b/src/operators/mpas_tracer_advection_helpers.F index f18570bd79..15c9ec22d4 100644 --- a/src/operators/mpas_tracer_advection_helpers.F +++ b/src/operators/mpas_tracer_advection_helpers.F @@ -188,7 +188,7 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ sorted_cell_indices(2, n) = cellsOnCell(i, cell1) call mpas_hash_insert(cell_hash, cellsOnCell(i, cell1)) end if - end do ! loop over i + end do do i = 1, nEdgesOnCell(cell2) if(.not. mpas_hash_search(cell_hash, cellsOnCell(i, cell2))) then @@ -198,7 +198,7 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ sorted_cell_indices(2, n) = cellsOnCell(i, cell2) call mpas_hash_insert(cell_hash, cellsOnCell(i, cell2)) end if - end do ! loop over i + end do call mpas_hash_destroy(cell_hash) @@ -207,11 +207,28 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ nAdvCellsForEdge(iEdge) = n do iCell = 1, nAdvCellsForEdge(iEdge) advCellsForEdge(iCell, iEdge) = sorted_cell_indices(2, iCell) - end do ! loop over iCell + end do + + ! equation 7 in Skamarock, W. C., & Gassmann, A. (2011): + ! F(u,psi)_{i+1/2} = u_{i+1/2} * + ! [ 1/2 (psi_{i+1} + psi_i) term 1 + ! - 1/12(dx^2psi_{i+1} + dx^2psi_i) term 2 + ! + sign(u) beta/12 (dx^2psi_{i+1} - dx^2psi_i)] term 3 (note minus sign) + ! + ! adv_coefs accounts for terms 1 and 2 in SG11 equation 7. Term 1 is + ! the 2nd-order flux-function term. adv_coefs accounts for this with + ! the "+ 0.5" lines below. In the advection routines that use these + ! coefficients, the 2nd-order flux loop is then skipped. Term 2 is + ! the 4th-order flux-function term. adv_coefs_3rd accounts for term + ! 3, the beta term. beta > 0 corresponds to the third-order flux + ! function. The - sign in the deriv_two accumulation is for the i+1 + ! part of term 3, while the + sign is for the i part. adv_coefs(:,iEdge) = 0. adv_coefs_3rd(:,iEdge) = 0. + ! pull together third and fourth order contributions to the flux + ! first from cell1 k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cell1)) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(1,1,iEdge) @@ -224,27 +241,30 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(iCell+1, 1, iEdge) adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) + deriv_two(iCell+1, 1, iEdge) end if - end do ! loop over iCell + end do + ! pull together third and fourth order contributions to the flux + ! now from cell2 k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cell2)) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(1,2,iEdge) - adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) + deriv_two(1,2,iEdge) + adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) - deriv_two(1,2,iEdge) end if do iCell = 1, nEdgesOnCell(cell2) k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cellsOnCell(iCell,cell2))) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + deriv_two(iCell+1, 2, iEdge) - adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) + deriv_two(iCell+1, 2, iEdge) + adv_coefs_3rd(k, iEdge) = adv_coefs_3rd(k, iEdge) - deriv_two(iCell+1, 2, iEdge) end if - end do ! loop over iCell + end do do iCell = 1,nAdvCellsForEdge(iEdge) adv_coefs (iCell,iEdge) = - (dcEdge(iEdge) **2) * adv_coefs (iCell,iEdge) / 12. adv_coefs_3rd(iCell,iEdge) = - (dcEdge(iEdge) **2) * adv_coefs_3rd(iCell,iEdge) / 12. - end do ! loop over iCell + end do + ! 2nd order centered contribution - place this in the main flux weights k = mpas_binary_search(sorted_cell_indices, 2, 1, nAdvCellsForEdge(iEdge), indexToCellID(cell1)) if(k <= nAdvCellsForEdge(iEdge)) then adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + 0.5 @@ -255,11 +275,12 @@ subroutine mpas_tracer_advection_coefficients( meshPool, horiz_adv_order, deriv_ adv_coefs(k, iEdge) = adv_coefs(k, iEdge) + 0.5 end if + ! multiply by edge length - thus the flux is just dt*ru times the results of the vector-vector multiply do iCell=1,nAdvCellsForEdge(iEdge) adv_coefs (iCell,iEdge) = dvEdge(iEdge) * adv_coefs (iCell,iEdge) adv_coefs_3rd(iCell,iEdge) = dvEdge(iEdge) * adv_coefs_3rd(iCell,iEdge) - end do ! loop over iCell - end if + end do + end if ! only do for edges of owned-cells end do ! end loop over edges deallocate(cell_indices) diff --git a/src/tools/CMakeLists.txt b/src/tools/CMakeLists.txt new file mode 100644 index 0000000000..513ae48cf1 --- /dev/null +++ b/src/tools/CMakeLists.txt @@ -0,0 +1,30 @@ + +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/input_gen/CMakeLists.txt b/src/tools/input_gen/CMakeLists.txt new file mode 100644 index 0000000000..2b8c770476 --- /dev/null +++ b/src/tools/input_gen/CMakeLists.txt @@ -0,0 +1,6 @@ + +add_executable(mpas_namelist_gen namelist_gen.c test_functions.c) +target_link_libraries(mpas_namelist_gen PUBLIC ${PROJECT_NAME}::external::ezxml) + +add_executable(mpas_streams_gen streams_gen.c test_functions.c) +target_link_libraries(mpas_streams_gen PUBLIC ${PROJECT_NAME}::external::ezxml) diff --git a/src/tools/input_gen/Makefile b/src/tools/input_gen/Makefile index 29c47a242d..4204692c67 100644 --- a/src/tools/input_gen/Makefile +++ b/src/tools/input_gen/Makefile @@ -4,14 +4,14 @@ EZXML_PATH= ../../external/ezxml NL_OBJS = namelist_gen.o test_functions.o ST_OBJS = streams_gen.o test_functions.o -XML_OBJS = $(EZXML_PATH)/ezxml.o +XML_OBJS = $(EZXML_PATH)/ezxml_tools.o all: ezxml ($(MAKE) -j 1 namelist_gen CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)") ($(MAKE) -j 1 streams_gen CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)") ezxml: - (cd $(EZXML_PATH); $(MAKE) CFLAGS="$(CFLAGS) $(TOOL_TARGET_ARCH)") + (cd $(EZXML_PATH); $(MAKE) CFLAGS="$(CFLAGS) $(TOOL_TARGET_ARCH)" OBJFILE="ezxml_tools.o") namelist_gen: ezxml $(NL_OBJS) $(XML_OBJS) $(CC) $(CPPFLAGS) $(CFLAGS) -I$(EZXML_PATH) -o $@ $(NL_OBJS) $(XML_OBJS) diff --git a/src/tools/registry/CMakeLists.txt b/src/tools/registry/CMakeLists.txt new file mode 100644 index 0000000000..7d18e3f3b6 --- /dev/null +++ b/src/tools/registry/CMakeLists.txt @@ -0,0 +1,17 @@ + +#Parsing library core-independent code +add_library(parselib dictionary.c fortprintf.c utility.c) +target_link_libraries(parselib PUBLIC ${PROJECT_NAME}::external::ezxml) +target_link_libraries(parselib PUBLIC ${PROJECT_NAME}::external::esmf) + +# Generate parser for each core +# +# Note: One parser is required per-core because the gen_inc.c depends on +# a pre-processor define MPAS_NAMELIST_SUFFIX which is core specific +foreach(_core IN LISTS MPAS_CORES) + add_executable(mpas_parse_${_core} parse.c gen_inc.c) + target_link_libraries(mpas_parse_${_core} PUBLIC parselib) + target_compile_definitions(mpas_parse_${_core} PRIVATE MPAS_NAMELIST_SUFFIX=${_core} + MPAS_GIT_VERSION=${MPAS_GIT_VERSION} + MPAS_EXE_NAME=${_core}_model) +endforeach() diff --git a/src/tools/registry/Makefile b/src/tools/registry/Makefile index 46d9d56394..1b1900d6a6 100644 --- a/src/tools/registry/Makefile +++ b/src/tools/registry/Makefile @@ -9,10 +9,10 @@ all: ezxml ($(MAKE) parse CPPFLAGS="$(CPPFLAGS)" CPPINCLUDES="$(CPPINCLUDES)") ezxml: - (cd $(EZXML_PATH); $(MAKE) CFLAGS="$(CFLAGS) $(TOOL_TARGET_ARCH)") + (cd $(EZXML_PATH); $(MAKE) CFLAGS="$(CFLAGS) $(TOOL_TARGET_ARCH)" OBJFILE="ezxml_tools.o") parse: $(OBJS) - $(CC) $(CPPFLAGS) $(CFLAGS) $(EZXML_PATH)/ezxml.o -I$(EZXML_PATH) -o $@ $(OBJS) + $(CC) $(CPPFLAGS) $(CFLAGS) $(EZXML_PATH)/ezxml_tools.o -I$(EZXML_PATH) -o $@ $(OBJS) parse.o: 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){/*{{{*/ + + char suffix[6]; + + if (time_levs > 1) { + snprintf(suffix, 6, "aPtr"); + } else { + snprintf(suffix, 6, "Ptr"); + } -int set_pointer_name(int type, int ndims, char *pointer_name){/*{{{*/ if(type == REAL) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "r0Ptr"); + snprintf(pointer_name, 1024, "r0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "r1Ptr"); + snprintf(pointer_name, 1024, "r1%s", suffix); break; case 2: - snprintf(pointer_name, 1024, "r2Ptr"); + snprintf(pointer_name, 1024, "r2%s", suffix); break; case 3: - snprintf(pointer_name, 1024, "r3Ptr"); + snprintf(pointer_name, 1024, "r3%s", suffix); break; case 4: - snprintf(pointer_name, 1024, "r4Ptr"); + snprintf(pointer_name, 1024, "r4%s", suffix); break; case 5: - snprintf(pointer_name, 1024, "r5Ptr"); + snprintf(pointer_name, 1024, "r5%s", suffix); break; } } else if (type == INTEGER) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "i0Ptr"); + snprintf(pointer_name, 1024, "i0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "i1Ptr"); + snprintf(pointer_name, 1024, "i1%s", suffix); break; case 2: - snprintf(pointer_name, 1024, "i2Ptr"); + snprintf(pointer_name, 1024, "i2%s", suffix); break; case 3: - snprintf(pointer_name, 1024, "i3Ptr"); + snprintf(pointer_name, 1024, "i3%s", suffix); break; } } else if (type == CHARACTER) { switch (ndims){ default: case 0: - snprintf(pointer_name, 1024, "c0Ptr"); + snprintf(pointer_name, 1024, "c0%s", suffix); break; case 1: - snprintf(pointer_name, 1024, "c1Ptr"); + snprintf(pointer_name, 1024, "c1%s", suffix); break; } } @@ -153,16 +319,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; }/*}}}*/ @@ -225,12 +393,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); } } @@ -249,12 +419,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); } } @@ -275,12 +447,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); } } @@ -530,7 +704,7 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ int in_subpool; - FILE *fd, *fd2; + FILE *fd, *fd2, *fcd, *fcg; const_core = ezxml_attr(registry, "core_abbrev"); @@ -538,6 +712,8 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fd = fopen("namelist_defines.inc", "w+"); fd2 = fopen("namelist_call.inc", "w+"); + fcd = fopen("config_declare.inc", "w+"); + fcg = fopen("config_get.inc", "w+"); fortprintf(fd2, " function %s_setup_namelists(configPool, namelistFilename, dminfo) result(iErr)\n", core_string); fortprintf(fd2, " use mpas_derived_types\n"); @@ -599,7 +775,7 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fortprintf(fd, " integer :: ierr\n"); fortprintf(fd, "\n"); - // Define variable defintions prior to reading the namelist in. + // Define variable definitions prior to reading the namelist in. for (nmlopt_xml = ezxml_child(nmlrecs_xml, "nml_option"); nmlopt_xml; nmlopt_xml = nmlopt_xml->next){ nmloptname = ezxml_attr(nmlopt_xml, "name"); nmlopttype = ezxml_attr(nmlopt_xml, "type"); @@ -611,9 +787,12 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ if(strncmp(nmlopttype, "real", 1024) == 0){ fortprintf(fd, " real (kind=RKIND) :: %s = %lf\n", nmloptname, (double)atof(nmloptval)); + fortprintf(fcd, " real (kind=RKIND), pointer :: %s\n", nmloptname); } else if(strncmp(nmlopttype, "integer", 1024) == 0){ fortprintf(fd, " integer :: %s = %d\n", nmloptname, atoi(nmloptval)); + fortprintf(fcd, " integer, pointer :: %s\n", nmloptname); } else if(strncmp(nmlopttype, "logical", 1024) == 0){ + fortprintf(fcd, " logical, pointer :: %s\n", nmloptname); if(strncmp(nmloptval, "true", 1024) == 0 || strncmp(nmloptval, ".true.", 1024) == 0){ fortprintf(fd, " logical :: %s = .true.\n", nmloptname); } else { @@ -621,9 +800,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ } } else if(strncmp(nmlopttype, "character", 1024) == 0){ fortprintf(fd, " character (len=StrKIND) :: %s = '%s'\n", nmloptname, nmloptval); + fortprintf(fcd, " character (len=StrKIND), pointer :: %s\n", nmloptname); } } fortprintf(fd, "\n"); + fortprintf(fcd, "\n"); // Define the namelist block, to read the namelist record in. fortprintf(fd, " namelist /%s/ &\n", nmlrecname); @@ -638,14 +819,17 @@ 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"); } fortprintf(fd, " if (dminfo %% my_proc_id == IO_NODE) then\n"); + fortprintf(fd, "! Rewinding before each read leads to errors when the code is built with\n"); + fortprintf(fd, "! the NAG Fortran compiler. If building with NAG, be kind and don't rewind.\n"); + fortprintf(fd, "#ifndef NAG_COMPILER\n"); fortprintf(fd, " rewind(unitNumber)\n"); + fortprintf(fd, "#endif\n"); fortprintf(fd, " read(unitNumber, %s, iostat=ierr)\n", nmlrecname); fortprintf(fd, " end if\n"); @@ -704,8 +888,10 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ nmloptname = ezxml_attr(nmlopt_xml, "name"); fortprintf(fd, " call mpas_pool_add_config(%s, '%s', %s)\n", pool_name, nmloptname, nmloptname); + fortprintf(fcg, " call mpas_pool_get_config(configPool, '%s', %s)\n", nmloptname, nmloptname); } fortprintf(fd, "\n"); + fortprintf(fcg, "\n"); // End new subroutine for namelist record. fortprintf(fd, " end subroutine %s_setup_nmlrec_%s\n", core_string, nmlrecname); @@ -716,6 +902,11 @@ int parse_namelist_records_from_registry(ezxml_t registry)/*{{{*/ fortprintf(fd2, " close(unitNumber)\n"); fortprintf(fd2, " end function %s_setup_namelists\n", core_string); + fclose(fd); + fclose(fd2); + fclose(fcd); + fclose(fcg); + return 0; }/*}}}*/ @@ -995,7 +1186,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; @@ -1015,6 +1206,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var char *string, *tofree, *token; char temp_str[1024]; char pointer_name[1024]; + char pointer_name_arr[1024]; char spacing[1024], sub_spacing[1024]; char default_value[1024]; char missing_value[1024]; @@ -1063,13 +1255,23 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var // Determine field type and default value. get_field_information(vararrtype, vararrdefaultval, default_value, vararrmissingval, missing_value, &type); + // If a default_value is not specified, but a missing_value is, then set the + // default_value (defaultValue) to missing_value + if(!vararrdefaultval && vararrmissingval) { + snprintf(default_value, 1024, "%s ! defaultValue taking specified missing_value", missing_value); + } + // Determine ndims, hasTime, and decomp type build_dimension_information(registry, var_arr_xml, &ndims, &hasTime, &decomp); ndims++; // Add a dimension for constituents in var_array // Determine name of pointer for this field. - set_pointer_name(type, ndims, pointer_name); - fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + set_pointer_name(type, ndims, pointer_name, time_levs); + if (time_levs > 1) { + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + } else { + fortprintf(fd, " allocate(%s)\n", pointer_name); + } fortprintf(fd, " index_counter = 0\n", spacing); fortprintf(fd, " group_counter = -1\n", spacing); @@ -1124,6 +1326,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, " "); @@ -1189,6 +1392,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, " "); @@ -1243,27 +1447,32 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, " end if\n"); for(time_lev = 1; time_lev <= time_levs; time_lev++){ + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } fortprintf(fd, "! Defining time level %d\n", time_lev); - fortprintf(fd, " allocate( %s(%d) %% constituentNames(numConstituents) )\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, vararrname); + fortprintf(fd, " allocate( %s %% constituentNames(numConstituents) )\n", pointer_name_arr); + fortprintf(fd, " %s %% fieldName = '%s'\n", pointer_name_arr , vararrname); if (decomp != -1) { - fortprintf(fd, " %s(%d) %% isDecomposed = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isDecomposed = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .false.\n", pointer_name_arr); } if (hasTime) { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .false.\n", pointer_name_arr); } - fortprintf(fd, " %s(%d) %% isVarArray = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isVarArray = .true.\n", pointer_name_arr); if(ndims > 0){ if(persistence == SCRATCH){ - fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .false.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .true.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } } fortprintf(fd, "\n"); @@ -1279,7 +1488,7 @@ 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); - fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); fortprintf(fd, " end if\n", spacing); } @@ -1288,7 +1497,7 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var // Setup dimensions fortprintf(fd, "! Setup dimensions for \n", vararrname); i = 1; - fortprintf(fd, " %s(%d) %% dimNames(%d) = 'num_%s'\n", pointer_name, time_lev, i, vararrname); + fortprintf(fd, " %s %% dimNames(%d) = 'num_%s'\n", pointer_name_arr, i, vararrname); string = strdup(vararrdims); tofree = string; @@ -1297,18 +1506,18 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var if(strncmp(token, "Time", 1024) != 0){ i++; if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } else { - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } } while( (token = strsep(&string, " ")) != NULL){ if(strncmp(token, "Time", 1024) != 0){ i++; if(strncmp(token, "nCells", 1024) == 0 || strncmp(token, "nEdges", 1024) == 0 || strncmp(token, "nVertices", 1024) == 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } else { - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); } } } @@ -1317,20 +1526,19 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var fortprintf(fd, "\n"); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% scalar = %s\n", pointer_name_arr, default_value); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); - fortprintf(fd, " allocate(%s(%d) %% attLists(size(%s(%d) %% constituentNames, dim=1)))\n", pointer_name, time_lev, pointer_name, time_lev); + fortprintf(fd, " %s %% defaultValue = %s\n", pointer_name_arr, default_value); + fortprintf(fd, " allocate(%s %% attLists(size(%s %% constituentNames, dim=1)))\n", pointer_name_arr, pointer_name_arr); - fortprintf(fd, " do index_counter = 1, size(%s(%d) %% constituentNames, dim=1)\n", pointer_name, time_lev); - fortprintf(fd, " allocate(%s(%d) %% attLists(index_counter) %% attList)\n", pointer_name, time_lev); + fortprintf(fd, " do index_counter = 1, size(%s %% constituentNames, dim=1)\n", pointer_name_arr); + fortprintf(fd, " allocate(%s %% attLists(index_counter) %% attList)\n", pointer_name_arr); 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"); @@ -1340,50 +1548,26 @@ 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(%d) %% attLists(const_index) %% attList, 'long_name', '%s')\n", pointer_name, time_lev, 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(%d) %% attLists(const_index) %% attList, 'units', '%s')\n", pointer_name, time_lev, temp_str); } - if ( vararrmissingval ) { - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, 'missing_value', %s)\n", pointer_name, time_lev, missing_value); - // Uncomment to add _FillValue to match missing_value - // fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(const_index) %% attList, '_FillValue', %s)\n", pointer_name, time_lev, missing_value); + add_attribute_if_not_ignored(fd, "const_index", "missing_value", pointer_name_arr, missing_value); } - fortprintf(fd, " %s(%d) %% missingValue = %s\n", pointer_name, time_lev, missing_value); - fortprintf(fd, " %s(%d) %% constituentNames(const_index) = '%s'\n", pointer_name, time_lev, varname); + fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); + fortprintf(fd, " %s %% constituentNames(const_index) = '%s'\n", pointer_name_arr, varname); fortprintf(fd, " end if\n", spacing); } - fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + fortprintf(fd, " %s %% block => block\n", pointer_name_arr); } // Parse packages if they are defined @@ -1400,11 +1584,17 @@ 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"); } for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, " %s%s(%d) %% isActive = .true.\n", spacing, pointer_name, time_lev); + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } + fortprintf(fd, " %s%s %% isActive = .true.\n", spacing, pointer_name_arr); } if (!no_packages) { @@ -1427,7 +1617,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; @@ -1443,6 +1633,7 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa char *string, *tofree, *token; char temp_str[1024]; char pointer_name[1024]; + char pointer_name_arr[1024]; char package_spacing[1024]; char default_value[1024]; char missing_value[1024]; @@ -1461,8 +1652,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){ @@ -1489,38 +1678,53 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa // Determine field type and default value. get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); + // If a default_value is not specified, but a missing_value is, then set the + // default_value (defaultValue) to missing_value + if(!vardefaultval && varmissingval) { + snprintf(default_value, 1024, "%s ! defaultValue taking specified missing_value", missing_value); + } + // Determine ndims, hasTime, and decomp type build_dimension_information(registry, var_xml, &ndims, &hasTime, &decomp); // Determine name of pointer for this field. - set_pointer_name(type, ndims, pointer_name); - - fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + set_pointer_name(type, ndims, pointer_name, time_levs); + if (time_levs > 1) { + fortprintf(fd, " allocate(%s(%d))\n", pointer_name, time_levs); + } else { + fortprintf(fd, " allocate(%s)\n", pointer_name); + } 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 { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } fortprintf(fd, "\n"); fortprintf(fd, "! Setting up time level %d\n", time_lev); - fortprintf(fd, " %s(%d) %% fieldName = '%s'\n", pointer_name, time_lev, varname); - fortprintf(fd, " %s(%d) %% isVarArray = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% fieldName = '%s'\n", pointer_name_arr, varname); + fortprintf(fd, " %s %% isVarArray = .false.\n", pointer_name_arr); if (decomp != -1) { - fortprintf(fd, " %s(%d) %% isDecomposed = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isDecomposed = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isDecomposed = .false.\n", pointer_name_arr); } if(hasTime) { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .true.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .true.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% hasTimeDimension = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% hasTimeDimension = .false.\n", pointer_name_arr); } if(ndims > 0){ if(persistence == SCRATCH){ - fortprintf(fd, " %s(%d) %% isPersistent = .false.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .false.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } else { - fortprintf(fd, " %s(%d) %% isPersistent = .true.\n", pointer_name, time_lev); - fortprintf(fd, " %s(%d) %% isActive = .false.\n", pointer_name, time_lev); + fortprintf(fd, " %s %% isPersistent = .true.\n", pointer_name_arr); + fortprintf(fd, " %s %% isActive = .false.\n", pointer_name_arr); } // Setup dimensions @@ -1530,65 +1734,36 @@ int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVa i = 1; token = strsep(&string, " "); if(strncmp(token, "Time", 1024) != 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); i++; } while( (token = strsep(&string, " ")) != NULL){ if(strncmp(token, "Time", 1024) != 0){ - fortprintf(fd, " %s(%d) %% dimNames(%d) = '%s'\n", pointer_name, time_lev, i, token); + fortprintf(fd, " %s %% dimNames(%d) = '%s'\n", pointer_name_arr, i, token); i++; } } free(tofree); } - fortprintf(fd, " %s(%d) %% defaultValue = %s\n", pointer_name, time_lev, default_value); + fortprintf(fd, " %s %% defaultValue = %s\n", pointer_name_arr, default_value); if ( ndims == 0 ) { - fortprintf(fd, " %s(%d) %% scalar = %s\n", pointer_name, time_lev, default_value); - } - fortprintf(fd, " allocate(%s(%d) %% attLists(1))\n", pointer_name, time_lev); - fortprintf(fd, " allocate(%s(%d) %% attLists(1) %% attList)\n", pointer_name, time_lev); - - 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(%d) %% attLists(1) %% attList, 'units', '%s')\n", pointer_name, time_lev, 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); + fortprintf(fd, " %s %% scalar = %s\n", pointer_name_arr, default_value); + } + fortprintf(fd, " allocate(%s %% attLists(1))\n", pointer_name_arr); + fortprintf(fd, " allocate(%s %% attLists(1) %% attList)\n", pointer_name_arr); + 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(%d) %% attLists(1) %% attList, 'long_name', '%s')\n", pointer_name, time_lev, temp_str); } + fortprintf(fd, " %s %% missingValue = %s\n", pointer_name_arr, missing_value); - if ( varmissingval != NULL ) { - fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, 'missing_value', %s)\n", pointer_name, time_lev, missing_value); - // Uncomment to add _FillValue to match missing_value - // fortprintf(fd, " call mpas_add_att(%s(%d) %% attLists(1) %% attList, '_FillValue', %s)\n", pointer_name, time_lev, missing_value); - } - fortprintf(fd, " %s(%d) %% missingValue = %s\n", pointer_name, time_lev, missing_value); - - fortprintf(fd, " %s(%d) %% block => block\n", pointer_name, time_lev); + fortprintf(fd, " %s %% block => block\n", pointer_name_arr); } @@ -1606,12 +1781,18 @@ 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"); } for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, " %s%s(%d) %% isActive = .true.\n", package_spacing, pointer_name, time_lev); + if (time_levs > 1) { + snprintf(pointer_name_arr, 1024, "%s(%d)", pointer_name, time_lev); + } else { + snprintf(pointer_name_arr, 1024, "%s", pointer_name); + } + fortprintf(fd, " %s%s %% isActive = .true.\n", package_spacing, pointer_name_arr); } if(varpackages != NULL){ @@ -1722,7 +1903,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); @@ -1784,211 +1964,6 @@ int determine_struct_depth(int curLevel, ezxml_t superStruct){/*{{{*/ }/*}}}*/ -int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct, ezxml_t registry){/*{{{*/ - ezxml_t subStruct; - ezxml_t var_arr_xml, var_xml; - const char *structname; - const char *vartimelevs; - const char *varname, *vardims, *vartype; - const char *vardefaultval, *varmissingval; - const char *varname_in_code; - int depth; - int err; - int has_time; - int time_lev, time_levs; - int ndims, type; - int decomp; - char *string, *tofree, *token; - char pointer_name[1024]; - char default_value[1024]; - char missing_value[1024]; - - depth = curLevel + 1; - - for(subStruct = ezxml_child(superStruct, "var_struct"); subStruct; subStruct = subStruct->next){ - structname = ezxml_attr(subStruct, "name"); - fortprintf(fd, "! ----------- NEW STRUCT ---------\n"); - fortprintf(fd, "! Get pointers to pools for struct %s\n", structname); - fortprintf(fd, "! --------------------------------\n"); - if(curLevel == 0){ - fortprintf(fd, " call mpas_pool_get_subpool(currentBlock %% structs, '%s', poolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(prevBlock %% structs, '%s', prevPoolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(nextBlock %% structs, '%s', nextPoolLevel%d)\n", structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - } else { - fortprintf(fd, " call mpas_pool_get_subpool(poolLevel%d, '%s', poolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(prevPoolLevel%d, '%s', prevPoolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(prevPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_subpool(nextPoolLevel%d, '%s', nextPoolLevel%d)\n", curLevel, structname, curLevel+1); - fortprintf(fd, " else\n"); - fortprintf(fd, " nullify(nextPoolLevel%d)\n", curLevel+1); - fortprintf(fd, " end if\n"); - } - - fortprintf(fd, "\n"); - // Link var arrays - for(var_arr_xml = ezxml_child(subStruct, "var_array"); var_arr_xml; var_arr_xml = var_arr_xml->next){/*{{{*/ - varname = ezxml_attr(var_arr_xml, "name"); - vardims = ezxml_attr(var_arr_xml, "dimensions"); - vartimelevs = ezxml_attr(var_arr_xml, "time_levs"); - vartype = ezxml_attr(var_arr_xml, "type"); - vardefaultval = ezxml_attr(var_arr_xml, "default_value"); - varmissingval = ezxml_attr(var_arr_xml, "missing_value"); - - if(!vartimelevs){ - vartimelevs = ezxml_attr(subStruct, "time_levs"); - } - - if(vartimelevs){ - time_levs = atoi(vartimelevs); - if(time_levs < 1){ - time_levs = 1; - } - } else { - time_levs = 1; - } - - if(!varmissingval){ - varmissingval = vardefaultval; - } - - // Determine field type and default value. - get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); - - // Determine number of dimensions - // and decomp type - build_dimension_information(registry, var_arr_xml, &ndims, &has_time, &decomp); - ndims++; // Add a dimension for var_arrays - - // Using type and ndims, determine name of pointer for field. - set_pointer_name(type, ndims, pointer_name); - - for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, "! Linking %s for time level %d\n", varname, time_lev); - fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " if(associated(%s)) then\n", pointer_name); - fortprintf(fd, "#ifdef MPAS_DEBUG\n"); - fortprintf(fd, " call mpas_log_write('Linking %s')\n", varname); - fortprintf(fd, "#endif\n"); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - - if(decomp == CELLS){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); - } else if(decomp == EDGES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); - } else if(decomp == VERTICES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); - } - - fortprintf(fd, " end if\n"); - } - - fortprintf(fd, "\n"); - }/*}}}*/ - - // Link independent vars - for(var_xml = ezxml_child(subStruct, "var"); var_xml; var_xml = var_xml->next){/*{{{*/ - varname = ezxml_attr(var_xml, "name"); - vardims = ezxml_attr(var_xml, "dimensions"); - vartimelevs = ezxml_attr(var_xml, "time_levs"); - vartype = ezxml_attr(var_xml, "type"); - vardefaultval = ezxml_attr(var_xml, "default_value"); - varmissingval = ezxml_attr(var_xml, "missing_value"); - varname_in_code = ezxml_attr(var_xml, "name_in_code"); - - if(!vartimelevs){ - vartimelevs = ezxml_attr(subStruct, "time_levs"); - } - - if(vartimelevs){ - time_levs = atoi(vartimelevs); - if(time_levs < 1){ - time_levs = 1; - } - } else { - time_levs = 1; - } - - if(!varname_in_code){ - varname_in_code = ezxml_attr(var_xml, "name"); - } - - if(!varmissingval){ - varmissingval = vardefaultval; - } - - // Determine field type and default value. - get_field_information(vartype, vardefaultval, default_value, varmissingval, missing_value, &type); - - // Determine number of dimensions - // and decomp type - build_dimension_information(registry, var_xml, &ndims, &has_time, &decomp); - - // Using type and ndims, determine name of pointer for field. - set_pointer_name(type, ndims, pointer_name); - - for(time_lev = 1; time_lev <= time_levs; time_lev++){ - fortprintf(fd, "! Linking %s for time level %d with name\n", varname, time_lev, varname_in_code); - fortprintf(fd, "#ifdef MPAS_DEBUG\n"); - fortprintf(fd, " call mpas_log_write('Linking %s with name %s')\n", varname, varname_in_code); - fortprintf(fd, "#endif\n"); - fortprintf(fd, " call mpas_pool_get_field(poolLevel%d, '%s', %s, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " if(associated(%s)) then\n", pointer_name); - fortprintf(fd, " if(associated(prevBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(prevPoolLevel%d, '%s', %s %% prev, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - fortprintf(fd, " if(associated(nextBlock)) then\n"); - fortprintf(fd, " call mpas_pool_get_field(nextPoolLevel%d, '%s', %s %% next, %d)\n", curLevel+1, varname_in_code, pointer_name, time_lev); - fortprintf(fd, " end if\n"); - - if(decomp == CELLS){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% cellsToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% cellsToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% cellsToCopy\n", pointer_name); - } else if(decomp == EDGES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% edgesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% edgesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% edgesToCopy\n", pointer_name); - } else if(decomp == VERTICES){ - fortprintf(fd, " %s %% sendList => currentBlock %% parinfo %% verticesToSend\n", pointer_name); - fortprintf(fd, " %s %% recvList => currentBlock %% parinfo %% verticesToRecv\n", pointer_name); - fortprintf(fd, " %s %% copyList => currentBlock %% parinfo %% verticesToCopy\n", pointer_name); - } - fortprintf(fd, " end if\n"); - - fortprintf(fd, "\n"); - } - }/*}}}*/ - - err = generate_struct_links(fd, curLevel+1, subStruct, registry); - } - - return 0; -}/*}}}*/ - - int generate_immutable_struct_contents(FILE *fd, const char *streamname, ezxml_t varstruct_xml){/*{{{*/ ezxml_t var_xml, vararr_xml, substruct_xml; @@ -2528,7 +2503,7 @@ int parse_structs_from_registry(ezxml_t registry)/*{{{*/ fd = fopen("structs_and_variables.inc", "w+"); for (structs_xml = ezxml_child(registry, "var_struct"); structs_xml; structs_xml = structs_xml->next){ - err = parse_struct(fd, registry, structs_xml, 0, '\0', corename); + err = parse_struct(fd, registry, structs_xml, 0, "\0", corename); } fortprintf(fd, " subroutine %s_generate_structs(block, structPool, dimensionPool, packagePool)\n", core_string); @@ -2557,5 +2532,3 @@ int parse_structs_from_registry(ezxml_t registry)/*{{{*/ return 0; }/*}}}*/ - - diff --git a/src/tools/registry/gen_inc.h b/src/tools/registry/gen_inc.h index 765dc0a230..fc94e78b79 100644 --- a/src/tools/registry/gen_inc.h +++ b/src/tools/registry/gen_inc.h @@ -9,10 +9,11 @@ #include "ezxml.h" -void write_model_variables(ezxml_t registry); -int write_field_pointers(FILE* fd); +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 macro_count, const char **macros); int write_field_pointer_arrays(FILE* fd); -int set_pointer_name(int type, int ndims, char *pointer_name); +int set_pointer_name(int type, int ndims, char *pointer_name, int time_levs); int add_package_to_list(const char * package, const char * package_list); int build_struct_package_lists(ezxml_t currentPosition, char * out_packages); int get_dimension_information(ezxml_t registry, const char *test_dimname, int *has_time, int *decomp); @@ -27,14 +28,13 @@ int parse_var_array(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t var int parse_var(FILE *fd, ezxml_t registry, ezxml_t superStruct, ezxml_t currentVar, const char * corename); int parse_struct(FILE *fd, ezxml_t registry, ezxml_t superStruct, int subpool, const char *parentname, const char * corename); int determine_struct_depth(int curLevel, ezxml_t superStruct); -int generate_struct_links(FILE *fd, int curLevel, ezxml_t superStruct, ezxml_t registry); int generate_field_exchanges(FILE *fd, int curLevel, ezxml_t superStruct); int generate_field_halo_exchanges_and_copies(ezxml_t registry); int generate_field_inputs(FILE *fd, int curLevel, ezxml_t superStruct); int generate_field_outputs(FILE *fd, int curLevel, ezxml_t superStruct); int generate_field_reads_and_writes(ezxml_t registry); +int generate_immutable_streams(ezxml_t registry); int push_attributes(ezxml_t currentPosition); int merge_structs_and_var_arrays(ezxml_t currentPosition); int merge_streams(ezxml_t registry); int parse_structs_from_registry(ezxml_t registry); - diff --git a/src/tools/registry/parse.c b/src/tools/registry/parse.c index 858ff0f77c..4e68576ba9 100644 --- a/src/tools/registry/parse.c +++ b/src/tools/registry/parse.c @@ -33,11 +33,14 @@ int main(int argc, char ** argv)/*{{{*/ struct package * pkgs; int err; - if (argc != 2) { - fprintf(stderr,"Reading registry file from standard input\n"); - regfile = stdin; + if (argc < 2) { + fprintf(stderr,"\nUsage: %s [macro definitions]\n\n", argv[0]); + fprintf(stderr," where [macro definitions] may be any number of macro\n"); + fprintf(stderr," definitions of the form -D[=]\n\n"); + return 1; } - else if (!(regfile = fopen(argv[1], "r"))) { + + if (!(regfile = fopen(argv[1], "r"))) { fprintf(stderr,"\nError: Could not open file %s for reading.\n\n", argv[1]); return 1; } @@ -58,7 +61,11 @@ int main(int argc, char ** argv)/*{{{*/ return 1; } - write_model_variables(registry); + if (argc > 2) { + write_model_variables(registry, (argc-2), (const char**)&argv[2]); + } else { + write_model_variables(registry, 0, NULL); + } if (parse_reg_xml(registry)) { fprintf(stderr, "Parsing failed.....\n"); diff --git a/src/tools/registry/utility.c b/src/tools/registry/utility.c index 444889d448..e722d399f8 100644 --- a/src/tools/registry/utility.c +++ b/src/tools/registry/utility.c @@ -9,6 +9,7 @@ #include #include #include +#include #include "ezxml.h" #include "registry_types.h" @@ -263,3 +264,78 @@ int check_persistence(const char * persistence){/*{{{*/ return PERSISTENT; } }/*}}}*/ + + +/****************************************************************************** + * + * parse_macros + * + * Given an array of strings that are assumed to be in the form of C + * pre-processor macro definitions, e.g., + * + * { "-DMPAS_NAMELIST_SUFFIX=test", + * "-DSINGLE_PRECISION", + * "-DHISTORY=Not available" } + * + * which could come from the command-line arguments + * + * -DMPAS_NAMELIST_SUFFIX=test -DSINGLE_PRECISION -DHISTORY="Not available" + * + * this routine parses the macro name and macro definition from each string, + * and invokes a callback routine with the macro name and definition. The macro + * name is the name of the macro itself, without the "-D" definition prefix. + * + * Any arguments after the macros argument to this function are passed as a + * va_list to the callback. + * + * For the above array of macro definition strings, the callback would be + * invoked three times with the following arguments: + * + * "MPAS_NAMELIST_SUFFIX", "test" + * "SINGLE_PRECISION", "" + * "HISTORY", "Not available" + * + * The callback function may be NULL. + * + * Upon successful completion, a value of 0 is returned. If errors were + * encountered in parsing macro definition strings, a non-zero value is + * returned. + * + ******************************************************************************/ +int parse_macros(void(*callback)(const char *macro, const char *val, va_list ap), + int count, const char **macros, ...) +{ + int i; + + for (i = 0; i < count; i++) { + char *tmp; + char *macrotmp; + char *macro; + char *val; + + tmp = strdup(macros[i]); + macrotmp = strtok_r(tmp, "=", &val); + + if (macrotmp == NULL || val == NULL) { + return 1; + } + + if (strstr(macrotmp, "-D") == macrotmp) { + macro = ¯otmp[2]; + } else { + macro = macrotmp; + } + + if (callback != NULL) { + va_list ap; + + va_start(ap, macros); + callback(macro, val, ap); + va_end(ap); + } + + free(tmp); + } + + return 0; +} diff --git a/src/tools/registry/utility.h b/src/tools/registry/utility.h index 37c9d0de27..90a2e83ca7 100644 --- a/src/tools/registry/utility.h +++ b/src/tools/registry/utility.h @@ -15,3 +15,5 @@ char * check_packages(ezxml_t registry, char * packages); char * check_dimensions(ezxml_t registry, char * dims); char * check_streams(ezxml_t registry, char * streams); int check_persistence(const char * persistence); +int parse_macros(void(*callback)(const char *macro, const char *val, va_list ap), + int count, const char **macros, ...); diff --git a/testing_and_setup/atmosphere/setup_atm_run_dir b/testing_and_setup/atmosphere/setup_atm_run_dir new file mode 100755 index 0000000000..b0734c2f5f --- /dev/null +++ b/testing_and_setup/atmosphere/setup_atm_run_dir @@ -0,0 +1,174 @@ +#! /bin/sh + +# Setup a run directory for the MPAS init_atmosphere, and atmosphere cores. + +###################################################################### +# usage() - Display the usage message +###################################################################### +usage() +{ + printf "Usage: setup_atm_run_dir setup-dir\n" +} + +###################################################################### +# init_atmosphere_setup() +# +# $1 - Run directory +# $2 - MPAS-Model Source Code Directory +# Setup the init_atmosphere in the run directory ($1) by linking the +# init_atmosphere exetuable and copying the init_atmosphere namelist and +# streams from the default_inputs/ directory. +# +# On error, the program will exit and will return 1, otherwise, 0 will be +# returned. +# +###################################################################### +init_atmosphere_setup() +{ + printf "Setting up the init_atmosphere core ...\n" + rundir=$1 + mpasdir=$2 + + # See if the init_amtosphere_model is compiled + if ! [ -f "${mpasdir}/init_atmosphere_model" ]; then + printf "The MPAS directory does not appear to have the init_atmosphere core compiled!\n" + return 1 + fi + + ln -s "${mpasdir}/init_atmosphere_model" $rundir + if [ $? -ne 0 ]; then + printf "Failed to link 'init_atmosphere_model' from %s\n" $mpasdir + return 1 + fi + + cp "${mpasdir}/default_inputs/namelist.init_atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'namelist.init_atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + cp "${mpasdir}/default_inputs/streams.init_atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'streams.init_atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + printf "Succesfully setup the run directory for the init_atmosphere model\n" + return 0 +} + +###################################################################### +# atmosphere_setup() +# +# $1 - Run directory +# $2 - MPAS-Model Source Code Directory +# Setup the atmosphere core in the run directory ($1) by linking the +# atmosphere_model exeutable, physics lookup tables, and by copying +# the needed namelist, streams, and stream_lists from the default_inputs/ +# directory. +# +# On error, this function 1 will be returned, otherwise, 0 will be +# returned. +# +###################################################################### +atmosphere_setup() +{ + printf "Setting up the atmosphere core ...\n" + rundir=$1 + mpasdir=$2 + + # See if the amtosphere core is compiled + if ! [ -f "${mpasdir}/atmosphere_model" ]; then + printf "The MPAS directory does not appear to have the atmosphere core compiled!\n" + return 1 + fi + + ln -s "${mpasdir}/atmosphere_model" $rundir + if [ $? -ne 0 ]; then + printf "Failed to link 'atmosphere_model' from %s\n" $mpasdir + return 1 + fi + + cp "${mpasdir}/default_inputs/namelist.atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'namelist.atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + cp "${mpasdir}/default_inputs/streams.atmosphere" $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'streams.atmosphere' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + cp ${mpasdir}/default_inputs/stream_list.atmosphere.* $rundir + if [ $? -ne 0 ]; then + printf "Failed to copy 'stream_list.atmosphere.*' from %s\n" "${mpasdir}/default_inputs" + return 1 + fi + + ln -s ${mpasdir}/src/core_atmosphere/physics/physics_wrf/files/* $rundir + if [ $? -ne 0 ]; then + printf "Failed to link physics files from %s\n" "${mpasdir}/src_core_atmosphere_physics/physics_wrf/files" + return 1 + fi + + printf "Succesfully setup the run directory for the atmosphere model\n" + return 0 +} + + +######################################################## +# +# setup_run_atm_run_dir.sh +# +# \brief Copy and link the needed files for running the init_atmosphere, and +# atmosphere core. +# \details +# Given a directory, copy or link all the needed executables, namelist, +# streams, stream_lists and physics lookup tables needed for both the +# init_atmosphere and atmosphere core. +# +# Currently, this script will need to be in the +# testing_and_setup/atmosphere directory of the MPAS-Model repository that is +# desired to be setup. If either the init_atmosphere or atmosphere core is +# compiled in the MPAS-Model directory, then it will be copied into the run +# directory. If a core is not compiled, it will not be copied. +# +######################################################## + +if [ $# -ne 1 ]; then + printf "Please provide a directory to setup a MPAS run\n" + usage + exit 1 +fi + +rundir=$1 + +if ! [ -d $rundir ]; then + printf "The given directory does not appear to be a directory\n" + exit 1 +fi + +# Find the location of this script, which will be used to find the the needed +# MPAS files. Note: $0 may fail here with some shells and some uncommon +# executions, see: http://mywiki.wooledge.org/BashFAQ/028 +cwd=`pwd` +cd `dirname $0` +this_script=`pwd` +cd $cwd +mpasdir=`dirname "$this_script"` +mpasdir=`dirname "$mpasdir"` + +# See if this is an MPAS directory (Check for src/core_atmosphere, +# and src/core_init_atmosphere) +if ! [ -d "${mpasdir}/src/core_atmosphere" ] || ! [ -d "${mpasdir}/src/core_init_atmosphere" ]; then + printf "ERROR: Can't seem to locate MPAS-Model directory!\n" + printf "ERROR: Please ensure that this script is in the testing_and_setup/atmosphere directory of\n" + printf "ERROR: the MPAS-Model you want to setup\n" + exit 1 +fi + +init_atmosphere_setup $rundir $mpasdir + +atmosphere_setup $rundir $mpasdir diff --git a/testing_and_setup/compass/clean_testcase.py b/testing_and_setup/compass/clean_testcase.py index 499c94f645..9aa66f806f 100755 --- a/testing_and_setup/compass/clean_testcase.py +++ b/testing_and_setup/compass/clean_testcase.py @@ -6,6 +6,10 @@ It will remove directories / driver scripts that were generated as part of setting up a test case. """ + +from __future__ import absolute_import, division, print_function, \ + unicode_literals + import sys import os import shutil @@ -21,7 +25,7 @@ description=__doc__, formatter_class=argparse.RawTextHelpFormatter) parser.add_argument("-o", "--core", dest="core", - help="Core that conatins configurations to clean", + help="Core that contains configurations to clean", metavar="CORE") parser.add_argument("-c", "--configuration", dest="configuration", help="Configuration to clean", metavar="CONFIG") @@ -51,16 +55,16 @@ if not args.case_num and (not args.core and not args.configuration and not args.resolution and not args.test) \ and not args.clean_all: - print 'Must be run with either the --case_number argument, the ' \ - '--all argument, or all of the core, configuration, ' \ - 'resolution, and test arguments.' + print('Must be run with either the --case_number argument, the ' + '--all argument, or all of the core, configuration, ' + 'resolution, and test arguments.') parser.error(' Invalid configuration. Exiting...') if args.case_num and args.core and args.configuration and args.resoltuion \ and args.test and args.clean_all: - print 'Can only be configured with either --case_number (-n), --all ' \ - '(-a), or all of --core (-o), --configuration (-c), ' \ - '--resolution (-r), and --test (-t).' + print('Can only be configured with either --case_number (-n), --all ' + '(-a), or all of --core (-o), --configuration (-c), ' + '--resolution (-r), and --test (-t).') parser.error(' Invalid configuration. Too many options used. ' 'Exiting...') @@ -80,7 +84,7 @@ regex = re.compile('(\d):') core_configuration = subprocess.check_output(['./list_testcases.py']) - for line in core_configuration.split('\n'): + for line in core_configuration.decode('utf-8').split('\n'): if regex.search(line) is not None: conf_arr = line.replace(":", " ").split() case_num = int(conf_arr[0]) @@ -99,7 +103,7 @@ os.chdir(os.path.dirname(os.path.realpath(__file__))) git_version = subprocess.check_output(['git', 'describe', '--tags', '--dirty']) - git_version = git_version.strip('\n') + git_version = git_version.decode('utf-8').strip('\n') os.chdir(old_dir) calling_command = "" write_history = False @@ -115,7 +119,7 @@ core_configuration = subprocess.check_output( ['./list_testcases.py', '-n', '{:d}'.format(int(case_num))]) - config_options = core_configuration.strip('\n').split(' ') + config_options = core_configuration.decode('utf-8').strip('\n').split(' ') args.core = config_options[1] args.configuration = config_options[3] args.resolution = config_options[5] @@ -153,8 +157,8 @@ if os.path.isdir('{}/{}'.format(work_dir, case_base)): shutil.rmtree('{}/{}'.format(work_dir, case_base)) write_history = True - print ' -- Removed case {}/{}'.format(work_dir, - case_base) + print(' -- Removed case {}/{}'.format(work_dir, + case_base)) # Process files elif config_root.tag == 'driver_script': @@ -164,8 +168,8 @@ if os.path.exists('{}/{}'.format(work_dir, script_name)): os.remove('{}/{}'.format(work_dir, script_name)) write_history = True - print ' -- Removed driver script ' \ - '{}/{}'.format(work_dir, script_name) + print(' -- Removed driver script ' + '{}/{}'.format(work_dir, script_name)) del config_tree del config_root @@ -190,7 +194,7 @@ core_configuration = subprocess.check_output( ['./list_testcases.py', '-n', '{:d}'.format(int(case_num))]) - config_options = core_configuration.strip('\n').split(' ') + config_options = core_configuration.decode('utf-8').strip('\n').split(' ') history_file.write('\n') history_file.write(' core: {}\n'.format(config_options[1])) history_file.write(' configuration: {}\n'.format( diff --git a/testing_and_setup/compass/list_testcases.py b/testing_and_setup/compass/list_testcases.py index 2d744910d7..f4e8f6a346 100755 --- a/testing_and_setup/compass/list_testcases.py +++ b/testing_and_setup/compass/list_testcases.py @@ -12,6 +12,9 @@ it will only print the flags needed to setup that specific test case. """ +from __future__ import absolute_import, division, print_function, \ + unicode_literals + import os import fnmatch import argparse @@ -19,9 +22,7 @@ import re -def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, - print_num): # {{{ - # Xylar: the indentation got out of hand and I had to make this a function +def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num): # Print the options if a case file was found. if not quiet: @@ -30,16 +31,14 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, config_dir): if (not args.resolution) or re.match(args.resolution, res_dir): if (not args.test) or re.match(args.test, test_dir): - print " {:d}: -o {} -c {} -r {} -t {}".format( - case_num, core_dir, config_dir, res_dir, test_dir) - if quiet and case_num == print_num: - print "-o {} -c {} -r {} -t {}".format( - core_dir, config_dir, res_dir, test_dir) + print(" {:d}: -o {} -c {} -r {} -t {}".format( + case_num, core_dir, config_dir, res_dir, test_dir)) + if quiet and case_num == args.number: + print("-o {} -c {} -r {} -t {}".format( + core_dir, config_dir, res_dir, test_dir)) case_num += 1 return case_num -# }}} - if __name__ == "__main__": # Define and process input arguments @@ -55,25 +54,16 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, help="Resolution to search for", metavar="RES") parser.add_argument("-t", "--test", dest="test", help="Test name to search for", metavar="TEST") - parser.add_argument("-n", "--number", dest="number", + parser.add_argument("-n", "--number", dest="number", type=int, help="If set, script will print the flags to use a " - "the N'th configuraiton.") + "the N'th configuration.") args = parser.parse_args() - quiet = False - - try: - print_num = 0 - if args.number: - quiet = True - print_num = int(args.number) - except ValueError: - args.number = 0 - print_num = 0 + quiet = args.number is not None if not quiet: - print "Available test cases are:" + print("Available test cases are:") # Start case numbering at 1 case_num = 1 @@ -82,23 +72,24 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, os.chdir(script_path) # Iterate over all cores - for core_dir in os.listdir('.'): + for core_dir in sorted(os.listdir('.')): if os.path.isdir(core_dir) and core_dir != '.git': # Iterate over all configurations within a core - for config_dir in os.listdir(core_dir): + for config_dir in sorted(os.listdir(core_dir)): config_path = '{}/{}'.format(core_dir, config_dir) if os.path.isdir(config_path): # Iterate over all resolutions within a configuration - for res_dir in os.listdir(config_path): + for res_dir in sorted(os.listdir(config_path)): res_path = '{}/{}'.format(config_path, res_dir) if os.path.isdir(res_path): # Iterate over all tests within a resolution - for test_dir in os.listdir(res_path): + for test_dir in sorted(os.listdir(res_path)): test_path = '{}/{}'.format(res_path, test_dir) if os.path.isdir(test_path): do_print = False # Iterate over all files within a test - for case_file in os.listdir(test_path): + for case_file in sorted( + os.listdir(test_path)): if fnmatch.fnmatch(case_file, '*.xml'): tree = ET.parse('{}/{}'.format( test_path, case_file)) @@ -118,7 +109,6 @@ def print_case(quiet, args, core_dir, config_dir, res_dir, test_dir, case_num, if do_print: case_num = print_case( quiet, args, core_dir, config_dir, - res_dir, test_dir, case_num, - print_num) + res_dir, test_dir, case_num) # vim: foldmethod=marker ai ts=4 sts=4 et sw=4 ft=python diff --git a/testing_and_setup/compass/manage_regression_suite.py b/testing_and_setup/compass/manage_regression_suite.py index b2c014cb81..a64e708305 100755 --- a/testing_and_setup/compass/manage_regression_suite.py +++ b/testing_and_setup/compass/manage_regression_suite.py @@ -12,6 +12,9 @@ for each individual test case, and the run script that runs all test cases. """ +from __future__ import absolute_import, division, print_function, \ + unicode_literals + import sys import os import fnmatch @@ -26,8 +29,8 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, if verbose: stdout = open(work_dir + '/manage_regression_suite.py.out', 'a') stderr = stdout - print ' Script setup outputs to {}'.format( - work_dir + '/manage_regression_suite.py.out') + print(' Script setup outputs to {}'.format( + work_dir + '/manage_regression_suite.py.out')) else: dev_null = open('/dev/null', 'a') stderr = dev_null @@ -37,40 +40,40 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, try: test_name = test_tag.attrib['name'] except KeyError: - print "ERROR: tag is missing 'name' attribute." - print "Exiting..." + print("ERROR: tag is missing 'name' attribute.") + print("Exiting...") sys.exit(1) try: test_core = test_tag.attrib['core'] except KeyError: - print "ERROR: tag with name '{}' is missing 'core' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'core' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) try: test_configuration = test_tag.attrib['configuration'] except KeyError: - print "ERROR: tag with name '{}' is missing 'configuration' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'configuration' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) try: test_resolution = test_tag.attrib['resolution'] except KeyError: - print "ERROR: tag with name '{}' is missing 'resolution' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'resolution' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) try: test_test = test_tag.attrib['test'] except KeyError: - print "ERROR: tag with name '{}' is missing 'test' " \ - "attribute.".format(test_name) - print "Exiting..." + print("ERROR: tag with name '{}' is missing 'test' " + "attribute.".format(test_name)) + print("Exiting...") sys.exit(1) # Determine the file name for the test case output @@ -91,8 +94,8 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, '-r', test_resolution, '-t', test_test, '-m', model_runtime, '-b', baseline_dir], stdout=stdout, stderr=stderr) - print " -- Setup case '{}': -o {} -c {} -r {} -t {}".format( - test_name, test_core, test_configuration, test_resolution, test_test) + print(" -- Setup case '{}': -o {} -c {} -r {} -t {}".format( + test_name, test_core, test_configuration, test_resolution, test_test)) # Write step into suite script to cd into the base of the regression suite suite_script.write("os.chdir(base_path)\n") @@ -111,8 +114,8 @@ def process_test_setup(test_tag, config_file, work_dir, model_runtime, try: script_name = script.attrib['name'] except KeyError: - print "ERROR: